Pop up message when clicked on icon on column headers

Viewed 178

While rendering DT table in shiny, is there a way to add pop up icon as shown below. So when user clicks on it, it should show some message :)

datatable(iris)  #### while rendering DT table

enter image description here

2 Answers

Since you mention in your comment that you’d like the contents of the message to also be clickable, you might be interested in Bootstrap Popovers. The shinyBS package provides some wrappers for them. However, I couldn’t get it to work with a datatable header, so I made some custom helpers:

# Enable popovers -- needs to be included again with dynamic content
usePopover <- function() {
  tags$script(HTML(
    "$(function () {
      $('[data-toggle=\"popover\"]').popover()
    })"
  ))
}

popover <- function(tag, content = NULL, title = NULL, options = list()) {
  if (!is.null(names(options))) {
    names(options) <- paste0("data-", names(options))
  }
  
  tag |>
    tagAppendAttributes(
      `data-toggle` = "popover",
      `data-content` = content,
      title = title,
      !!!options
    )
}

You can use these in a datatable column header by defining a custom columDefs element for the target column. While we’re there, we can also use the same mechanism to inject the info icon, after making sure to include the required dependency in the UI.

Avoiding the sorting behaviour when clicking on the icon in the header takes some extra work. Essentially, you have to make sure the click event doesn't bubble up to the event listeners in the datatable. For the icon, that can be done with JavaScript in a direct click handler on the element. For the popover itself, we can use a different container (body, in this case) so that it's no longer included inside the table in the DOM.

Here’s how this comes together:

library(shiny)
library(DT)

ui <- fluidPage(
  # Need to add FontAwesome manually because no `icon()` calls in UI.
  fontawesome::fa_html_dependency(),
  DTOutput("table")
)

server <- function(input, output, session) {
  output$table <- renderDT({
    datatable(
      data = iris,
      options = list(
        columnDefs = list(
          list(
            targets = 4,
            title = paste(
              "Petal.Width",
              icon("info-circle") |>
                popover(
                  tags$a(href = "https://stackoverflow.com", "Stack Overflow"),
                  # Prevent sorting when clicking on popover
                  options = list(html = TRUE, container = "body")
                ) |>
                tagAppendAttributes(
                  # Prevent sorting when clicking on icon
                  onclick = "event.stopPropagation();"
                ) |>
                tagList(usePopover())
            )
          )
        )
      )
    )
  })
}

shinyApp(ui, server)

And it ends up looking something like this:

popover on icon in datatable header

You can set the column names like this:

library(shiny)
library(DT)

ui <- fluidPage(
  DTOutput("table")
)

server <- function(input, output, session) {
  output$table <- renderDataTable(escape = FALSE, {
    colnames(iris) <- c("Sepal Length", "Sepal Width", "Petal Length",
       "Petal Width <div title ='Hover tooltip'>info</div>", "Species")
    iris
  })
}

shinyApp(ui, server)

enter image description here

However, things like shiny::icon("info-circle") don't in the colnames.

Related