R shiny 带有反应列和弹出工具提示的数据表

Question

Does anyone know how to integrate reactive columns with popover tooltips in R shiny?

I have some working code for reactive columns using Datatable based off this post and code:

library(shiny)
library(DT)

server<-function(input, output,session) { 
  
  shinyInput <- function(FUN, len, id, ivals, ...) {
    inputs <- numeric(len)
    for (i in seq_len(len)) {
      inputs[i] <- as.character(
        FUN(paste0(id, i), label = NULL,
            value=ivals[i],...)
      )
    }
    inputs
  }
  
  it_df <- reactive({
    data.frame(
      Parameters = rep("X",7),
      Values = shinyInput(numericInput, 7,
                          'param_values', 
                          numeric(7),
                          width = '100%'),
      stringsAsFactors = FALSE
    )
  })
  output$param_table <- DT::renderDataTable(
    datatable(it_df(),escape = FALSE,
              options = list(
                preDrawCallback = JS("function() { Shiny.unbindAll(this.api().table().node());}"),
                drawCallback = JS("function() { Shiny.bindAll(this.api().table().node());}")
              )
    ))
}

ui <- fluidPage( DT::dataTableOutput('param_table'))

shinyApp(ui,server)

I also have some working code for popover tooltips based off this post and code:

library(shiny)
library(DT)

ui<-shinyUI(
  mainPanel(
    DT::dataTableOutput("tbl")
  )   
) 

server<-shinyServer(function(input, output,session) {
  output$tbl = DT::renderDataTable(
    datatable(iris[1:5, ], callback = JS("
                                    var tips = ['First row name', 'Second row name', 'Third row name',
                                    'Fourth row name', 'Fifth row name'],
                                    firstColumn = $('#tbl tr td:first-child');
                                    for (var i = 0; i < tips.length; i++) {
                                    $(firstColumn[i]).attr('title', tips[i]);
                                    }")), server = FALSE)
}) 

shinyApp(ui = ui, server = server)

But I'm having a lot of trouble combining the two. Partly due to my lack of JS knowledge.

Thanks and any help is much appreciated!

Answer 1

Just combine two javascript code that you provided in one datatable function. This should work:

library(shiny)
library(DT)

ui<-shinyUI(
  mainPanel(
    DT::dataTableOutput("tbl")
  )   
) 

server<-shinyServer(function(input, output,session) {
  shinyInput <- function(FUN, len, id, ivals, ...) {
    inputs <- numeric(len)
    for (i in seq_len(len)) {
      inputs[i] <- as.character(
        FUN(paste0(id, i), label = NULL,
            value=ivals[i],...)
      )
    }
    inputs
  }
  
  it_df <- reactive({
    data.frame(
      Parameters = rep("X",5),
      Values = shinyInput(numericInput, 5,
                          'param_values', 
                          numeric(5),
                          width = '100%'),
      stringsAsFactors = FALSE
    )
  })
  output$tbl = DT::renderDataTable(
    datatable(it_df(), escape = FALSE, options = list(
      preDrawCallback = JS("function() { Shiny.unbindAll(this.api().table().node());}"),
      drawCallback = JS("function() { Shiny.bindAll(this.api().table().node());}")
    ),
    callback = JS("
                                    var tips = ['First row name', 'Second row name', 'Third row name',
                                    'Fourth row name', 'Fifth row name'],
                                    firstColumn = $('#tbl tr td:first-child');
                                    for (var i = 0; i < tips.length; i++) {
                                    $(firstColumn[i]).attr('title', tips[i]);
                                    }")), server = FALSE)
}) 

shinyApp(ui = ui, server = server)