add popovers to shiny app?

问题:

I would like to add a (?) next to the title of a widget so that the user can hover or click it and get extra information and a link they can click.

This is what I have right now:

## app.R ##
library(shiny)
library(shinydashboard)
library(shinyBS)
# Header
header <- dashboardHeader()
# Sidebar
sidebar <- dashboardSidebar(fileInput("chosenfile", label = h4("File input"), 
                                      accept = ".csv"),
                            bsButton("q1", label = "", icon = icon("question"),
                                     style = "info", size = "extra-small"),
                            bsPopover(id = "q1", title = "Tidy data",
                                      content = paste0("You should read the ", 
                                                       a("tidy data paper", 
                                                         href = "http://vita.had.co.nz/papers/tidy-data.pdf",
                                                         target="_blank")),
                                      placement = "right", 
                                      trigger = "click", 
                                      options = list(container = "body")
                                      )
                            )
# Body
body <- dashboardBody()
# ui
ui <- dashboardPage(header, sidebar, body)
# server
server <- function(input, output) {

}
# run
shinyApp(ui, server)

But it is far from perfect. For example the placement of the (?) is not next to "File input" and to close the popover you have to click the question mark again instead of having an (x) in the popover.

回答1:

this answer is probably not what you initially wanted, but it could still be working for you.

You said you wanted the tooltip question mark next to the label, so I put it into the label. With the correct alignment. Second, you wanted the tooltip not to be open until the button is clicked again, because this is irritating. The popover option "focus" then might be the right thing for you.

## app.R ##
library(shiny)
library(shinydashboard)
library(shinyBS)
# Header
header <- dashboardHeader()
# Sidebar
sidebar <- dashboardSidebar(
  fileInput("chosenfile", 
    label = h4("File input ",
              tags$style(type = "text/css", "#q1 {vertical-align: top;}"),
              bsButton("q1", label = "", icon = icon("question"), style = "info", size = "extra-small")
            ),
    accept = ".csv"),
  bsPopover(id = "q1", title = "Tidy data",
    content = paste0("You should read the ", 
                a("tidy data paper", 
                  href = "http://vita.had.co.nz/papers/tidy-data.pdf",
                  target="_blank")
                ),
    placement = "right", 
    trigger = "focus", 
    options = list(container = "body")
  )
)
# Body
body <- dashboardBody()
# ui
ui <- dashboardPage(header, sidebar, body)
# server
server <- function(input, output) {}
# run
shinyApp(ui, server)

回答2:

I don't know much about JS either but this post has helped me a lot with 'styling' shinyapps.

One way to display widgets in the same line is to put each of them inside a div with 'style:inline-block'. Because the fileInput is too large, the (?) keeps being moved to next line, so you can forcibly tell how much space will the fileInput occuppy with 'width: somepercetage%' or 'width: somepixels px'.

Following these ideas the code would look like this:

div(
  div(
    # edit1
    style="width:80%; display:inline-block; vertical-align: middle;",
    fileInput("chosenfile", label = h4("File input"), 
              accept = ".csv")
  ),
  div(
    # edit2
    style="display:inline-block; vertical-align: middle;",
    bsButton("q1", label = "", icon = icon("question"),
             style = "info"),
    bsPopover(id = "q1", title = "Tidy data",
              content = paste0("You should read the ", 
                               a("tidy data paper", 
                               href = "http://vita.had.co.nz/papers/tidy-data.pdf",
                                 target="_blank")),
              placement = "right", 
              trigger = "click", 
              options = list(container = "body")
    )
  )
)