How can I render HTML content in an R Shiny Popify (ShinyBS) tooltip?

Question

I'm building out a datatable in R Shiny and part of it will include tooltips unique to each cell. I've accomplished that, however, I seem to be unable to insert HTML content into the tooltip itself. In the example below, I'm inserting HTML content into a cell in the datatable, and then aim to insert that same content into a tooltip, but the HTML only renders in the datatable, and not in the tooltip.

I've played around with a few ideas but can't find any that work. I can get the HTML to appear (as text) in the tooltip by removing the HTML function, but then, obviously, it's escaped and is just text. I am able to bold text within the tooltip using tags$b(), however, I am hoping for a solution more similar to my example below as I have more complex HTML content I would like add to the tooltip beyond just text.

Any ideas? Thanks very much!

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

ui <- fluidPage(
  bsTooltip('tbutton',''),
  mainPanel(dataTableOutput('df'))
)

server <- function(input, output) {
  
  df <- data.frame(A = c(1:5), B = c(LETTERS[1:5]))
  
  output$df <- renderDataTable({
    
    cell <- paste0('<svg width="30" height="30">',
                   '<text x="1%" y="75%" font-weight="bold" font-size="16" >B</text>',
                   '</svg>')
    
    df[2,2] <- as.character(popify(tags$div(HTML(cell)),
                                   title = 'Tooltip:',
                                   placement = 'left',
                                   content = paste0(tags$div(HTML(cell))),
                                   trigger = c('hover', 'click')))
    
    datatable(df, escape=FALSE)
  })
}

shinyApp(ui = ui, server = server)

Answer 1

To attach a popover to a cell, you can use bsPopover if this cell has an id. To set an id to the cells, you can use the datatables option createdCell.

Then the HTML code works in the popover content, but not the SVG (or at least I didn't manage to make it work).

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

df <- data.frame(A = 1:5, B = LETTERS[1:5])

css <- "
.red {color: red;}
"

ui <- fluidPage(
  tags$head(tags$style(HTML(css))),
  mainPanel(
    DTOutput('df'),
    bsPopover(
      id = "id2",
      title = "test",
      content = '<p class="red">TEST</p>'
    )
  )
)

server <- function(input, output) {
  
  output$df <- renderDT({
    datatable(
      df,
      options = list(
        columnDefs = list(
          list(
            targets = 2,
            createdCell = JS(
              "function (td, cellData, rowData, row, col) {",
              "  $(td).attr('id', 'id' + (row+1));",
              "}"
            )
          )
        )
      )
    )
    
  })
}

shinyApp(ui = ui, server = server)