Add label to sparkline plot in datatable

Question

Is it possible to add a custom label to a sparkline plot?

For example, in the code below, I would like to label each bar with the corresponding letter in the label column.

Building from a previous [answer]

require(sparkline)
require(DT)
require(shiny)
require(tibble)

# create data


spark_data1<-tribble(
  ~id,  ~label,~spark,
  "a", c("C,D,E"),c("1,2,3"),
  "b", c("C,D,E"),c("3,2,1")
)

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

server <- function(input, output) {

  output$tbl <- DT::renderDataTable({
    line_string <- "type: 'bar'"
    cd <- list(list(targets = 2, render = JS("function(data, type, full){ return '<span class=sparkSamples>' + data + '</span>' }")))
    cb = JS(paste0("function (oSettings, json) {\n  $('.sparkSamples:not(:has(canvas))').sparkline('html', { ", 
                   line_string, " });\n}"), collapse = "")
    dt <-  DT::datatable(as.data.frame(spark_data1),  rownames = FALSE, options = list(columnDefs = cd,fnDrawCallback = cb))

  })

}

shinyApp(ui = ui, server = server)

Answer 1

Ok, so we start by getting the sparklines in the datatable. This Github issue might be helpful and offers what I think is a better approach than the original and popular Combining data tables and sparklines post.

Add sparkline in datatable

I will comment #### inline to explain the changes.

require(sparkline)
require(DT)
require(shiny)
require(tibble)

# create data

spark_data1<-tribble(
  ~id,  ~label,~spark,
#### use sparkline::spk_chr helper
####   note spk_chr build for easy usage with dplyr, summarize
  "a", c("C,D,E"),spk_chr(1:3,type="bar"),
  "b", c("C,D,E"),spk_chr(3:1,type="bar")
)

ui <- tagList(
  fluidPage(
    DT::dataTableOutput("tbl")
  ),
#### add dependencies for sparkline in advance
#### since we know we are using
  htmlwidgets::getDependency("sparkline", "sparkline")
) 

server <- function(input, output) {

  output$tbl <- DT::renderDataTable({
    cb <- htmlwidgets::JS('function(){debugger;HTMLWidgets.staticRender();}')

    dt <-  DT::datatable(
      as.data.frame(spark_data1),
      rownames = FALSE,
      escape = FALSE,
      options = list(
#### add the drawCallback to static render the sparklines
####   staticRender will not redraw what has already been rendered
        drawCallback =  cb
      )
    )

  })

}

shinyApp(ui = ui, server = server)

Add the Labelled Tooltip

We'll make a little helper function borrowing lessons from Github issue.

#### helper function for adding the tooltip
spk_tool <- function(labels) {
  htmlwidgets::JS(
    sprintf(
"function(sparkline, options, field){
  return %s[field[0].offset];
}",
    jsonlite::toJSON(labels)
    )
  )
}

Altogether

live example

require(sparkline)
require(DT)
require(shiny)
require(tibble)

#### helper function for adding the tooltip
spk_tool <- function(labels) {
  htmlwidgets::JS(
    sprintf(
"function(sparkline, options, field){
  return %s[field[0].offset];
}",
    jsonlite::toJSON(labels)
    )
  )
}

# create data
spark_data1<-tribble(
  ~id,  ~spark,
#### use sparkline::spk_chr helper
####   note spk_chr build for easy usage with dplyr, summarize
  "a", spk_chr(1:3,type="bar", tooltipFormatter=spk_tool(c("C","D","E"))),
  "b", spk_chr(3:1,type="bar",tooltipFormatter=spk_tool(c("C","D","E")))
)

ui <- tagList(
  fluidPage(
    DT::dataTableOutput("tbl")
  ),
#### add dependencies for sparkline in advance
#### since we know we are using
  htmlwidgets::getDependency("sparkline", "sparkline")
) 

server <- function(input, output) {

  output$tbl <- DT::renderDataTable({
    cb <- htmlwidgets::JS('function(){debugger;HTMLWidgets.staticRender();}')

    dt <-  DT::datatable(
      as.data.frame(spark_data1),
      rownames = FALSE,
      escape = FALSE,
      options = list(
#### add the drawCallback to static render the sparklines
####   staticRender will not redraw what has already been rendered
        drawCallback =  cb
      )
    )

  })

}

shinyApp(ui = ui, server = server)