rshinydt

Add Popover to Column Name in Datatable


I am trying to add a button to a column name in a dabletable and a bsPopover to that button when it is hovered over. I can successfully create the popover and button outside of datatable, and I can add in a button to a datatable. But getting the popover to work in the datatable has proved unsuccessful. I am choosing 'hover' as the trigger so that clicking preserves column sorting capabilities. See reprex below:

library(shiny)
library(shinyBS)
library(DT)

ui <- fluidPage(
  titlePanel('Making a Popover Work in DataTable'),
  mainPanel(
    fluidRow(
      #popover button
      p(bsButton("workingPop",
                 label = "",
                 icon = icon("question"),
                 style = "info",
                 size = "extra-small")
      ),        
      #popover content
      bsPopover(id = "workingPop", title = "This Popover Works",
                content = "It works very well",
                placement = "right",
                trigger = "hover",
                options = list(container = "body")
      )),
    fluidRow(dataTableOutput('myTable'),
             bsPopover(id="notWorking", title = "This one does not work",
                       content = "I'd like to give information about hp: it means horsepower. I want a popover, because my real example has lot's of text.",
                       placement = "top",
                       trigger = "hover",
                       options = list(container = "body")))
  )
)

server <- function(input, output, session) {
  output$myTable <- DT::renderDataTable({
    datatable(mtcars %>%
                rename("hp <button type='button' id='notWorking' class='btn action-button btn-info btn-xs shiny-bound-input'>
  <i class='fa fa-question' role='presentation' aria-label='question icon'></i>
    </button>"=hp),
              rownames=TRUE,
              selection='none',
              escape=FALSE)
  })
}

shinyApp(ui = ui, server = server)

Solution

  • Please consider using alternatives of {shinyBs}.

    I would recommend you to try my package {spsComps} which has similar bsPopover functions but with a lot more you can do, like color, opacity, font size, weight, etc.

    shinyBs has not been updated for more than 5 years, I am sure you know what it means. It is not me trying to advertise my package so say something bad about shinyBs. I developed these functions because I don't see them in other packages or they didn't keep updating the package.

    Here is the use case for your example:

    library(shiny)
    library(spsComps)
    library(DT)
    library(dplyr)
    # define the question button in a button since we need to uses multiple times
    infoBtn <- function(id) {
        actionButton(id,
                     label = "",
                     icon = icon("question"),
                     style = "info",
                     size = "extra-small",
                     class='btn action-button btn-info btn-xs shiny-bound-input'
        )
    }
    ui <- fluidPage(
        titlePanel('Making a Popover Work in DataTable'),
        mainPanel(
            fluidRow(
                #popover button
                infoBtn('workingPop') %>% 
                    bsPopover(title = "This Popover Works",
                          content = "It works very well",
                          placement = "right",
                          trigger = "hover"
                    )
            ),
            fluidRow(dataTableOutput('myTable'))
        )
    )
    
    server <- function(input, output, session) {
        output$myTable <- DT::renderDataTable({
            # construct the title and convert to text
            hp_text <- tags$span(
                "hp", 
                infoBtn('notWorking') %>% 
                    bsPopover(title = "This one does not work",
                              content = "I'd like to give information about hp: it means horsepower. I want a popover, because my real example has lot's of text.",
                              placement = "top",
                              trigger = "hover")
            ) %>% 
                as.character()
            # use !! and := to inject variable as text
            datatable(mtcars %>% rename(!!hp_text:=hp),
                      rownames=TRUE,
                      selection='none',
                      escape=FALSE)
        })
    }
    
    shinyApp(ui = ui, server = server)
    
    

    enter image description here

    other popOver utilities you can do with spsComps:

    There are demos you can explore spsComps and docs you can read.