解决Shiny中renderDataTable调用as.datatable的警告并保留单元格格式

出现该警告的核心原因是DT::renderDataTable的参数规则限制：

• 当renderDataTable内部表达式返回普通数据框时，函数会自动调用datatable()构造DT对象，此时传入的server、plugins、options等外部参数均会生效
• 当你已经在表达式内部通过as.datatable()返回了现成的DT对象时，renderDataTable外层的额外参数会被直接丢弃，因此触发警告

将原本写在renderDataTable()外部的参数，全部移动到as.datatable()的参数列表中，renderDataTable()仅保留构造DT对象的逻辑即可，调整后既保留原有单元格格式效果，也不会再触发警告。

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]) # 确认为数值类型
    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)

内容的提问来源于stack exchange，提问作者MaskofIllusion