Resolving warning in as.datatable in a renderDatatable

Question

I have this shiny app below which I want to resolve the warning. The current warning I am getting is Warning in processWidget(instance) : renderDataTable ignores ... arguments when expr yields a datatable object; see ?renderDataTable. I know it is due to the as.datatable() call within the renderDataTable() call as mentioned here: R shiny widgetFunc() warning messages with eventReactive(warning 1) and renderDataTable (warning 2)

What I do want to know is how can I change the app below not to have the warning anymore but still to retain the formatting on my cells? It is not entirely evident how best to re-arrange it.

library(shiny)
library(shinydashboard)
library(DT)
library(formattable)


custom_color_picker <- function(x){
  
  sapply(x,function(x){
    if(x > 0){
      formattable::csscolor("#B7D1DA", format = "hex")
    } else {
      formattable::csscolor("#D38591", format = "hex")
    }
  }
  )
}

paddedcolor_bar <- function(color = "lightgray", fun = "proportion", fun2 = "custom_color_picker", ...) {
  fun <- match.fun(fun)
  fun2 <- match.fun(fun2)
  formatter("span",
            style = function(x) style(
              display = "inline-block",
              direction = "rtl",
              "unicode-bidi" = "plaintext",
              "border-radius" = "4px",
              "padding-right" = "2px",
              "background-color" = fun2(as.numeric(x), ...),
              width = sprintf("%010.4f%%", 100 * percent(fun(as.numeric(x), ...)))
            ))
}

ui <- dashboardPage(
  dashboardHeader(),
  dashboardSidebar(),
  dashboardBody(
    DT::dataTableOutput("tabOut")   
  )
) 

server <- function(input, output) {


  output$tabOut <- DT::renderDataTable({
    
    tab <- data.frame(A = -5:20, B = runif(26,0,10), C = letters)
    tab[, 1] <- as.numeric(tab[, 1]) # to be sure it's numerical
    

    as.datatable(
      formattable(tab, 
                  list("A"  = paddedcolor_bar("lightblue"),
                       "B" = formatter("span", x ~ sprintf("%10.2f", x, rank(-x)))))
    )
  }, server = FALSE, plugins = 'natural', options = list(
    columnDefs = list(list(type = "natural", targets = "_all")))
  )

  
}

shinyApp(ui, server)

^{Created on 2021-10-26 by the reprex package (v2.0.0)}

Answer 1

As the warning mentions renderDataTable ignores ... arguments when expr yields a datatable object - accordingly you need to pass the ... objects directly to the datatable function or in this case to the as.datatable function:

library(shiny)
library(shinydashboard)
library(DT)
library(formattable)

custom_color_picker <- function(x) {
  sapply(x, function(x) {
    if (x > 0) {
      formattable::csscolor("#B7D1DA", format = "hex")
    } else {
      formattable::csscolor("#D38591", format = "hex")
    }
  })
}

paddedcolor_bar <-
  function(color = "lightgray",
           fun = "proportion",
           fun2 = "custom_color_picker",
           ...) {
    fun <- match.fun(fun)
    fun2 <- match.fun(fun2)
    formatter(
      "span",
      style = function(x)
        style(
          display = "inline-block",
          direction = "rtl",
          "unicode-bidi" = "plaintext",
          "border-radius" = "4px",
          "padding-right" = "2px",
          "background-color" = fun2(as.numeric(x), ...),
          width = sprintf("%010.4f%%", 100 * percent(fun(
            as.numeric(x), ...
          )))
        )
    )
  }

ui <- dashboardPage(dashboardHeader(),
                    dashboardSidebar(),
                    dashboardBody(DT::dataTableOutput("tabOut")))

server <- function(input, output) {
  
  output$tabOut <- DT::renderDataTable({
    tab <- data.frame(A = -5:20,
                      B = runif(26, 0, 10),
                      C = letters)
    tab[, 1] <- as.numeric(tab[, 1]) # to be sure it's numerical
    
    as.datatable(
      formattable(tab,
                  list(
                    "A" = paddedcolor_bar("lightblue"),
                    "B" = formatter("span", x ~ sprintf("%10.2f", x))
                  ))
      # ,
      # plugins = 'natural',
      # options = list(columnDefs = list(
      #   list(type = "natural", targets = "_all")
      # ))
    )
  }, server = FALSE)
}

shinyApp(ui, server)

Here only server is not a ... argument to renderDataTable.