Tooltip in shiny UI for help text

问题:

I want to place a help text for check-box label as a tooltip. In the following example I use the shinyBS package - but I only get it to work for the title of the checkbox input group.

Any ideas how it could work after the "Lernerfolg" or "Enthusiasmus" labels?

library(shiny)
library(shinyBS)
 server <- function(input, output) {
  output$distPlot <- renderPlot({
    hist(rnorm(input$obs), col = 'darkgray', border = 'white')

  output$rendered <-   renderUI({
    checkboxGroupInput("qualdim",  tags$span("Auswahl der Qualitätsdimension",   
      tipify(bsButton("pB2", "?", style = "inverse", size = "extra-small"),
             "Here, I can place some help")),

                       c("Lernerfolg"             = "Lernerfolg"   , 
                         "Enthusiasmus"           = "Enthusiasmus"          
                         ),
                       selected = c("Lernerfolg"))


  })

  })
}

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      sliderInput("obs", "Number of observations:", min = 10, max = 500, value = 100),
      uiOutput("rendered")
    ),
    mainPanel(plotOutput("distPlot"))
  )
)

shinyApp(ui = ui, server = server)

回答1:

Sadly, this is one of these moments, where shiny hides most of the construction, which makes it hard to get what you want into the right places.

But like most of the time, some JavaScript will do the trick. I wrote you a function that inserts the bsButton in the right place and calls a shinyBS function to insert the tooltip. (I mainly reconstructed what tipify and bdButton would have done.) With the function you can modifify your tooltip easily without further knowledge about JavaScript.

If you'd like to know more of the details, just ask in comments.

Note: When you refer to the checkbox, use the value of it (the value that is sent to input$qualdim)

library(shiny)
library(shinyBS)

server <- function(input, output) {

  makeCheckboxTooltip <- function(checkboxValue, buttonLabel, Tooltip){
    script <- tags$script(HTML(paste0("
          $(document).ready(function() {
            var inputElements = document.getElementsByTagName('input');
            for(var i = 0; i < inputElements.length; i++){
              var input = inputElements[i];

              if(input.getAttribute('value') == '", checkboxValue, "'){
                var buttonID = 'button_' + Math.floor(Math.random()*1000);

                var button = document.createElement('button');
                button.setAttribute('id', buttonID);
                button.setAttribute('type', 'button');
                button.setAttribute('class', 'btn action-button btn-inverse btn-xs');
                button.appendChild(document.createTextNode('", buttonLabel, "'));

                input.parentElement.parentElement.appendChild(button);
                shinyBS.addTooltip(buttonID, \"tooltip\", {\"placement\": \"bottom\", \"trigger\": \"hover\", \"title\": \"", Tooltip, "\"}) 
              };
            }
          });
        ")))
     htmltools::attachDependencies(script, shinyBS:::shinyBSDep)
  }

  output$distPlot <- renderPlot({
    hist(rnorm(input$obs), col = 'darkgray', border = 'white')

    output$rendered <-   renderUI({
      list(
        checkboxGroupInput("qualdim",  tags$span("Auswahl der Qualitätsdimension",   
          tipify(bsButton("pB2", "?", style = "inverse", size = "extra-small"), "Here, I can place some help")),
          choices = c("Lernerfolg" = "Lernerfolg", "Enthusiasmus" = "Enthusiasmus"),
          selected = c("Lernerfolg")),
        makeCheckboxTooltip(checkboxValue = "Lernerfolg", buttonLabel = "?", Tooltip = "Look! I can produce a tooltip!")
      )
    })

  })
}

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      sliderInput("obs", "Number of observations:", min = 10, max = 500, value = 100),
      uiOutput("rendered")
    ),
    mainPanel(plotOutput("distPlot"))
  )
)

shinyApp(ui = ui, server = server)

Edit:

Added the ShinyBS Dependencies such that the JavaScript API for shinyBS is loaded into the WebSite. Before, this was (more or less accidentally) happening because of the other call to bsButton.

Edit Nr.2: Much more In-Shiny

So this JavaScript thing is quite nice, but is kinda prone to errors and demands the developer to have some additional language skills.

Here, I present another answer, inspired by @CharlFrancoisMarais , that works only from within R and makes things more integrated than before.

Main things are: An extension function to the checkboxGrouInput that allows for adding any element to each of the Checkbox elements. There, one can freely place the bsButton and tooltips, like you would in normal markup, with all function arguments supported.

Second, an extension to the bsButton to place it right. This is more of a custom thing only for @CharlFrancoisMarais request.

I'd suggest you read the Shiny-element manipulation carefully, because this offers so much customization on R level. I'm kinda exited.

Full Code below:

library(shiny)
library(shinyBS)

extendedCheckboxGroup <- function(..., extensions = list()) {
  cbg <- checkboxGroupInput(...)
  nExtensions <- length(extensions)
  nChoices <- length(cbg$children[[2]]$children[[1]])

  if (nExtensions > 0 && nChoices > 0) {
    lapply(1:min(nExtensions, nChoices), function(i) {
      # For each Extension, add the element as a child (to one of the checkboxes)
      cbg$children[[2]]$children[[1]][[i]]$children[[2]] <<- extensions[[i]]
    })
  }
  cbg
}

bsButtonRight <- function(...) {
  btn <- bsButton(...)
  # Directly inject the style into the shiny element.
  btn$attribs$style <- "float: right;"
  btn
}

server <- function(input, output) {
  output$distPlot <- renderPlot({
    hist(rnorm(input$obs), col = 'darkgray', border = 'white')

    output$rendered <-   renderUI({
      extendedCheckboxGroup("qualdim", label = "Checkbox", choiceNames  = c("cb1", "cb2"), choiceValues = c("check1", "check2"), selected = c("check2"), 
                              extensions = list(
                                tipify(bsButtonRight("pB1", "?", style = "inverse", size = "extra-small"),
                                       "Here, I can place some help"),
                                tipify(bsButtonRight("pB2", "?", style = "inverse", size = "extra-small"),
                                       "Here, I can place some other help")
                              ))
    })
  })
}

ui <- fluidPage(
  shinyjs::useShinyjs(),

  tags$head(HTML("<script type='text/javascript' src='sbs/shinyBS.js'></script>")),

  # useShinyBS

  sidebarLayout(
    sidebarPanel(
      sliderInput("obs", "Number of observations:", min = 10, max = 500, value = 100),
      uiOutput("rendered")
    ),
    mainPanel(plotOutput("distPlot"))
  )
)

shinyApp(ui = ui, server = server)

回答2:

Here is slight change - to add tooltips only to the checkboxes.

library(shiny)
library(shinyBS)

server <- function(input, output) {

makeCheckboxTooltip <- function(checkboxValue, buttonLabel, buttonId, Tooltip){
tags$script(HTML(paste0("
                        $(document).ready(function() {
                          var inputElements = document.getElementsByTagName('input');
                          for(var i = 0; i < inputElements.length; i++) {

                            var input = inputElements[i];
                            if(input.getAttribute('value') == '", checkboxValue, "' && input.getAttribute('value') != 'null') {

                              var button = document.createElement('button');
                              button.setAttribute('id', '", buttonId, "');
                              button.setAttribute('type', 'button');
                              button.setAttribute('class', 'btn action-button btn-inverse btn-xs');
                              button.style.float = 'right';
                              button.appendChild(document.createTextNode('", buttonLabel, "'));

                              input.parentElement.parentElement.appendChild(button);
                              shinyBS.addTooltip('", buttonId, "', \"tooltip\", {\"placement\": \"right\", \"trigger\": \"click\", \"title\": \"", Tooltip, "\"}) 
                            };
                          }
                        });
                        ")))
                        }

output$distPlot <- renderPlot({
hist(rnorm(input$obs), col = 'darkgray', border = 'white')

output$rendered <-   renderUI({
    checkboxGroupInput("qualdim", 
                       label = "Checkbox",
                       choiceNames  = c("cb1", "cb2"),
                       choiceValues = c("check1", "check2"),
                       selected = c("check2"))
})

output$tooltips <-   renderUI({
  list(
    makeCheckboxTooltip(checkboxValue = "check1", buttonLabel = "?", buttonId = "btn1", Tooltip = "tt1!"),
    makeCheckboxTooltip(checkboxValue = "check2", buttonLabel = "?", buttonId = "btn2", Tooltip = "tt2!")
  )
})

  })
}

ui <- fluidPage(
  shinyjs::useShinyjs(),

  tags$head(HTML("<script type='text/javascript' src='sbs/shinyBS.js'></script>")),

  # useShinyBS

  sidebarLayout(
sidebarPanel(
  sliderInput("obs", "Number of observations:", min = 10, max = 500, value = 100),
  uiOutput("rendered"),
  uiOutput("tooltips")
),
    mainPanel(plotOutput("distPlot"))
  )
)

shinyApp(ui = ui, server = server)