解决 renderDatatable 中 as.datatable 中的警告

Question

我有这个闪亮的应用程序，我想在它下面解决警告。我收到的当前警告是Warning in processWidget(instance) : renderDataTable ignores ... arguments when expr yields a datatable object; see ?renderDataTable。我知道这是由于这里提到的renderDataTable() 调用中的as.datatable() 调用：R shiny widgetFunc() warning messages with eventReactive(warning 1) and renderDataTable (warning 2)

我想知道的是如何更改下面的应用程序，使其不再出现警告，但仍保留单元格上的格式？如何最好地重新安排它并不完全清楚。

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)

^{由reprex package (v2.0.0) 于 2021 年 10 月 26 日创建}

Answer 1

正如警告中提到的renderDataTable ignores ... arguments when expr yields a datatable object - 因此，您需要将... 对象直接传递给datatable 函数，或者在这种情况下传递给as.datatable 函数：

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)

这里只有server 不是... 的renderDataTable 参数。