Enable percentBar plugin

[cwilligv]

Hi,

Is it possible to enable and use this datatable plugin? percentBar, for making a column that holds % value, a percentage bar.

Cheers.

---

By filing an issue to this repo, I promise that

• [x] I have fully read the issue guide at https://yihui.org/issue/.
• [x] I have provided the necessary information about my issue.
  • If I'm asking a question, I have already asked it on Stack Overflow or RStudio Community, waited for at least 24 hours, and included a link to my question there.
  • If I'm filing a bug report, I have included a minimal, self-contained, and reproducible example, and have also included xfun::session_info('DT'). I have upgraded all my packages to their latest versions (e.g., R, RStudio, and R packages), and also tried the development version: remotes::install_github('rstudio/DT').
  • If I have posted the same issue elsewhere, I have also mentioned it in this issue.
• [x] I have learned the Github Markdown syntax, and formatted my issue correctly.

I understand that my issue may be closed if I don't fulfill my promises.

[philibe]

You can try this with sparkline to workaround:

library(shiny)
library(DT)
library(sparkline)
library(dplyr)

ui <- basicPage(
  h2("The mtcars data"),
  sparklineOutput("only to load sparkline"),
  p("with sparkline"),
  DT::dataTableOutput("mytable")
)

server <- function(input, output) {

  output$mytable = DT::renderDataTable({
    datas <- (mtcars
              %>% select (mpg,cyl,disp)
              %>% mutate(
                max_disp=max(disp), 
                sparkline_disp=paste(100*disp/max_disp,100,sep=","),
                sparkline_disp_graph=sparkline_disp
              )
              %>% select(mpg,cyl,disp,sparkline_disp_graph, everything())
    )            

    escape_vector<- -(which(colnames(datas) %in% c(
      "sparkline_disp_graph",
      use.names = FALSE
    ))    +1)

    vector_value_sparkline=(which(colnames(datas) =="sparkline_disp_graph")    )

    sparkline_line_string <- "type: 'bullet', lineColor: 'black', fillColor: '#ccc', highlightLineColor: 'orange', highlightSpotColor: 'orange'"

    res<-DT::datatable(datas,
                       escape =escape_vector,
                       options = list(
                         columnDefs= list(
                           list(
                             targets = vector_value_sparkline,
                             render = JS("function(data, type, full){ return '<span class=sparkSamples>' + data + '</span>' }")
                           )
                         ),
                         fnDrawCallback = JS(paste0("function (oSettings, json) {\n  $('.sparkSamples:not(:has(canvas))').sparkline('html', { ",
                                                    sparkline_line_string, " });\n}"), collapse = "")
                       )
    )
    res
  })
}

shinyApp(ui, server)

[philibe]

I've forgotten that DT can do that:

• https://rstudio.github.io/DT/functions.html

library(shiny)
library(DT)
library(dplyr)

ui <- basicPage(
  h2("The mtcars data"),
  p("with base DT formatStyle() and styleColorBar()"),  
  DT::dataTableOutput("mytable2")
)

server <- function(input, output) {

  output$mytable2 = DT::renderDataTable({
    datas <- (mtcars
              %>% dplyr::select (mpg,cyl,disp)
    )            

    res<-DT::datatable(datas,
                       options = list(
                         pageLength =5
                       )
    )

    res<- (res
           %>% formatStyle(
             columns = c("disp"),
             background = styleColorBar(datas$disp, 'steelblue',angle = -90),
             backgroundSize = '90% 100%',
             backgroundRepeat = 'no-repeat',
             backgroundPosition = 'center'
           )
    )
    res
  })
}

shinyApp(ui, server)

And my previous answer updated:

library(shiny)
library(DT)
library(sparkline)
library(dplyr)

ui <- basicPage(
  h2("The mtcars data"),
  sparklineOutput("only to load sparkline"),
  p("with sparkline"),
  DT::dataTableOutput("mytable")
)

server <- function(input, output) {

  output$mytable = DT::renderDataTable({
    datas <- (mtcars
              %>% select (mpg,cyl,disp)
              %>% mutate(
                max_disp=max(disp),
                disp_pct=round(100*disp/max_disp,2),
                sparkline_disp=paste(disp_pct,100,sep=","),
                sparkline_disp_graph=sparkline_disp
              )
              %>% select(mpg,cyl,disp,sparkline_disp_graph, everything())
    )            

    escape_vector<- -(which(colnames(datas) %in% c(
      "sparkline_disp_graph",
      use.names = FALSE
    ))    +1)

    vector_value_sparkline=(which(colnames(datas) =="sparkline_disp_graph")    )
    vector_disp_pct=(which(colnames(datas) =="disp_pct")    )

    sparkline_line_string <- "type: 'bullet', lineColor: 'black', fillColor: '#ccc', highlightLineColor: 'orange', highlightSpotColor: 'orange'"

    res<-DT::datatable(datas,
                       # escape =escape_vector,
                       options = list(
                         pageLength =5,
                         columnDefs= list(
                           list(
                             targets = vector_value_sparkline,
                             render = JS(paste0(
                               "function(data, type, full){",
                               "  return '<span class=sparkSamples>' + data + '</span>&nbsp;'",
                               "  +full[",vector_disp_pct[1],"].toString()+'%'",
                               "}"
                             ))
                           )
                         ),
                         fnDrawCallback = JS(paste0("function (oSettings, json) {\n  $('.sparkSamples:not(:has(canvas))').sparkline('html', { ",
                                                    sparkline_line_string, " });\n}"), collapse = "")
                       )
    )
    res
  })

}

shinyApp(ui, server)

[cwilligv]

hey @philibe , thank you so much. This is great stuff!!! I was so focused on getting the JS part working that I ignored these options. I guess this is good enough.

Cheers.

[stla]

In order to use a plugin, it is always possible to download it and then to add it to the HTML dependencies of the DT table.

library(shiny)
library(DT)
library(htmltools)

dat <- iris[, 1:3]
dat$percentage <- paste0(rpois(nrow(dat), 50), "%")

dep <- htmlDependency(
  "percentageBars",
  version = "1.1",
  src = normalizePath("www"),
  script = "percentageBars.js",
  all_files = FALSE
)

dtable <- datatable(
  dat,
  rownames = FALSE,
  options = list(
    columnDefs = list(
      list(
        targets = list(3),
        render = 
          JS("DataTable.render.percentBar( 'round','#FFF', '#269ABC', '#31B0D5', '#286090', 1, 'groove' )")
      )
    )
  )
)
dtable$dependencies <- c(dtable$dependencies, list(dep))

ui <- fluidPage(
  br(),
  DTOutput("dtable")
)

server <- function(input, output, session) {

  output[["dtable"]] <- renderDT({
    dtable
  })

}

shinyApp(ui, server)

Looks good.

[philibe]

Ha yes :). I have tried to do that (JS("DataTable.render.percentBar()")) ie like in the datatable net js page, but DataTable.render.percentBar was unknown at this point, after some tries.

it is always possible (..) to add it to the HTML dependencies of the DT table.

Thanks for the tips htmlDependency( "percentageBars") :)