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)

Answer 2

Given that

Frequently Asked Questions

Why are there no axis labels/markers?

Sparklines are intended to be small enough to fit alongside a line of text, to give a quick impression of a trend or pattern and thus don't have the paraphernalia of full sized charts. As of version 2.0 you can mouse over the sparklines to see the underlying data.

From sparkline FAQ

adding a printed label over each bar is not a functionality of sparklines.

However, you are able to change the mouseover of the bar to your desired labels (e.g. "C", "D", and "E") and the color of each bar. I've taken the liberty of also making the bar charts larger/wider so that the mouseover option is more user-intuitive.

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

# 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', 
                                height:'50', width:'200', barWidth:'20', 
                            tooltipFormat: '{{offset:offset}}',
                            tooltipValueLookups: {
                                'offset': {
                                    0: 'C',
                                    1: 'D',
                                    2: 'E',
                                }
                            },
                            colorMap: ['red','blue','yellow']"
                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)