如何在数据表中为“迷你图”对象创建弹出窗口？

Question

以下代码将在数据表中创建一个“迷你图”图。我想修改代码，使其在鼠标悬停时在一个小弹出屏幕（如工具提示）中显示“Sparkline”图。

我已经完成了“showModal”功能，但无法实现。谢谢。

require(sparkline)
require(DT)
require(shiny)
require(dplyr)


ui <- fluidPage(
  sparklineOutput("ooooooooo"),
  DT::dataTableOutput("tbl")
)

server <- function(input, output) {

  df <- data.frame(
    season = rep(1992:1993, each=5), 
    result = c(1,0,1,-1,0,0,1,1,0,-1), 
    goals = c(2,0,1,0,3,0,2,3,1,0)
  )
  x = df %>%
    group_by(season) %>%
    summarize(
      result = paste(result, collapse = ","),
      goals = paste(goals, collapse = ",")
    )
  columnDefs = list(list(
    targets = c(1,2),
    render = JS("function(data, type, full){
                return '<span class=spark>' + data + '</span>'}")
    ))
  fnDrawCallback = JS("function (oSettings, json) {
                      $('.spark:not(:has(canvas))').sparkline('html', {
                      type: 'bar',
                      highlightColor: 'orange'
                      });}"
  )
  d1 <- datatable(x,options = list(
    columnDefs = columnDefs,
    fnDrawCallback = fnDrawCallback
  ))
  output$tbl <- renderSparkline({d1})
  }

shinyApp(ui = ui, server = server)

Answer 1

以下代码大致完成了它的工作。欢迎提出任何建议（特别是自动关闭）。

require(sparkline)
require(DT)
require(shiny)
require(dplyr)
require(shinyBS)


ui <- fluidPage(
  sparklineOutput("ooooooooo"),
  DT::dataTableOutput("tbl"),
  uiOutput("plot")
)

server <- function(session, input, output) {
  # Data Creation
  df <- data.frame(
    season = rep(1992:1993, each=5), 
    result = c(100,-20,10,-17,23,-34,111,61,30,-31), 
    goals = c(-22,30,-15,50,-32,20,-42,13,-11,50)
  )
  x = df %>%
    group_by(season) %>%
    summarize(
      result = paste(result, collapse = ","),
      goals = paste(goals, collapse = ",")
    )

  # Creating sparkline object into datatable cell
  columnDefs = list(list(
    targets = c(1,2),
    render = JS("function(data, type, full){
                return '<span class=spark>' + data + '</span>'}")
    ))
  fnDrawCallback = JS("function (oSettings, json) {
                      $('.spark:not(:has(canvas))').sparkline('html', {
                      type: 'bar',
                      highlightColor: 'orange'
                      });}"
  )

  # This will return the cell value as output object
  callback = JS("/* code for cell content on click */
                table.on('mouseenter', 'td', function() {
                var td = $(this);
                var info_out = table.cell( this ).data();
                Shiny.onInputChange('hoverIndexJS', info_out);
                });"

  )
  d1 <- datatable(x,options = list(
    columnDefs = columnDefs,
    fnDrawCallback = fnDrawCallback
  ), callback = callback)

  output$tbl <- renderSparkline({d1})

  # function to create butterfly plot
  color_from_middle <- function (data, color1,color2){
    max_val=max(abs(data))
    JS(sprintf("isNaN(parseFloat(value)) || value < 0 ? 'linear-gradient(90deg, transparent, transparent ' + (50 + value/%s * 50) + '%%, %s ' + (50 + value/%s * 50) + '%%,%s  50%%,transparent 50%%)': 'linear-gradient(90deg, transparent, transparent 50%%, %s 50%%, %s ' + (50 + value/%s * 50) + '%%, transparent ' + (50 + value/%s * 50) + '%%)'",
               max_val,color1,max_val,color1,color2,color2,max_val,max_val))
  }


  # Creating a shiny Popover
  observeEvent(input$hoverIndexJS, {
    toggleModal(session, "bsModel", "open")
  })


  output$plot <- renderUI({
    if(!is.null(input$hoverIndexJS)){
      df <- data.frame(x = sapply(strsplit(input$hoverIndexJS, ","), as.numeric))
      bsModal("bsModel", "sparkline Object: ", "DoNotKnowWhyItIsNeeded", size = "small",
              renderDT(datatable(df,rownames = F, colnames=NULL, options = list(dom = "t"))
                       %>% formatStyle('x',background = color_from_middle(range(df$x), 'red','green'))
              )
      )

    }
  })

  }

shinyApp(ui = ui, server = server)

Answer 2

这是做同样事情的另一种方式。

require(sparkline)
require(DT)
require(shiny)
require(dplyr)
require(shinyBS)


ui <- fluidPage(
  sparklineOutput("ooooooooo"),
  DT::dataTableOutput("tbl"),
  uiOutput("popover")
)

server <- function(session, input, output) {
  # Data Creation
  df <- data.frame(
    season = rep(1992:1993, each=5), 
    result = c(100,-20,10,-17,23,-34,111,61,30,-31), 
    goals = c(-22,30,-15,50,-32,20,-42,13,-11,50)
  )
  x = df %>%
    group_by(season) %>%
    summarize(
      result = paste(result, collapse = ","),
      goals = paste(goals, collapse = ",")
    )

  # Creating sparkline object into datatable cell
  columnDefs = list(list(
    targets = c(2,3),
    render = JS("function(data, type, full){
                return '<span class=spark>' + data + '</span>'}")
    ))
  fnDrawCallback = JS("function (oSettings, json) {
                      $('.spark:not(:has(canvas))').sparkline('html', {
                      type: 'bar',
                      highlightColor: 'orange'
                      });}"
  )

  # This will return the cell value as output object
  callback = JS("/* code for cell content on click */
                table.on('mouseenter', 'td', function() {
                var td = $(this);
                var info_out = table.cell( this ).data();
                Shiny.onInputChange('hoverIndexJS', info_out);
                });"

  )
  d1 <- datatable(x,options = list(
    columnDefs = columnDefs,
    fnDrawCallback = fnDrawCallback
  ), callback = callback)

  output$tbl <- renderSparkline({d1})

  # function to create butterfly popover
  color_from_middle <- function (data, color1,color2){
    max_val=max(abs(data))
    JS(sprintf("isNaN(parseFloat(value)) || value < 0 ? 'linear-gradient(90deg, transparent, transparent ' + (50 + value/%s * 50) + '%%, %s ' + (50 + value/%s * 50) + '%%,%s  50%%,transparent 50%%)': 'linear-gradient(90deg, transparent, transparent 50%%, %s 50%%, %s ' + (50 + value/%s * 50) + '%%, transparent ' + (50 + value/%s * 50) + '%%)'",
               max_val,color1,max_val,color1,color2,color2,max_val,max_val))
  }


  #our modal dialog box
  myModal <- function(failed=FALSE){
    modalDialog(
      renderDT({
        if(!is.null(input$hoverIndexJS)){
          df <- data.frame(x = sapply(strsplit(input$hoverIndexJS, ","), as.numeric))
          return(
            datatable(df,rownames = F, colnames=NULL, options = list(dom = "t"))
            %>% formatStyle('x',background = color_from_middle(range(df$x), 'red','green')) 
          )
        }
      }),
      easyClose = TRUE
    )
  }
  #event to trigger the modal box to appear
  observeEvent(input$hoverIndexJS,{
    if(!is.null(input$hoverIndexJS)){
      showModal(myModal()) 
    }
  })


  }

shinyApp(ui = ui, server = server)