Question

我有一个Shiny应用程序呈现一个数据表，我想在其中合并2个条件格式设置功能

将逗号添加到大于1000的数字
当第2列的值大于等于第1列的1.3x值时，将蓝色背景应用于第2列的值。当第2列的值小于等于第1列中的.7x值时，应用红色背景。

我问了一个有关如何在此SO帖子中加入逗号的问题。我在下面的脚本中删除了rowcallback参数，逗号正确呈现。同样，如果我注释掉dom和formatCurrency参数，则突出显示的条件填充也将正确呈现。

Content-Disposition: attachment; filename=abcd
Content-Encoding: deflate
Transfer-Encoding: chunked
Content-Type: application/octet-stream

但是，当我两个都留着时，数据表挂起并带有“正在处理”消息。

Answer 1

这里是避免使用rowCallback的状态：

library(shiny)
library(DT)
library(data.table)

shinyApp(
  ui = fluidPage(
    DTOutput("dummy_data_table")
  ),

  server = function(input, output) {

    myDisplayData <- data.table(A=c(100000, 200000, 300000), B=c(140000, 80000, 310000))
    myWorkData <- copy(myDisplayData)
    myWorkData[, colors := ifelse(B >= A*1.03, 'rgb(0,255,255)', 'rgb(255, 255, 255)')]
    myWorkData[colors %in% 'rgb(255, 255, 255)', colors := ifelse(B <= A*.7, 'rgb(255, 0, 0)', 'rgb(255, 255, 255)')]

    output$dummy_data_table <- DT::renderDataTable(
      DT::datatable(
        myDisplayData,
        extensions = 'Buttons',
        options = list(
          pageLength = 50,
          scrollX=TRUE,
          dom = 'T<"clear">lBfrtip'
        )
      ) %>% formatStyle('B', target = 'cell', backgroundColor = styleEqual(myDisplayData$B, myWorkData$colors)) %>% 
        formatCurrency(1:2, currency = "", interval = 3, mark = ",")
    ) # close renderDataTable

  }
)

编辑-------------------------

如果您喜欢使用data.frame：

library(shiny)
library(DT)

shinyApp(
  ui = fluidPage(
    DTOutput("dummy_data_table")
  ),

  server = function(input, output) {

    myDisplayData <- data.frame(A=c(100000, 200000, 300000), B=c(140000, 80000, 310000))

    MyColors <- vector(mode = 'character', length = 0L)

    for (i in seq(nrow(myDisplayData))) {
      A <- myDisplayData$A[i]
      B <- myDisplayData$B[i]
      if (B >= A * 1.03) {
        MyColors[i] <- 'rgb(0,255,255)'
      } else if (B <= A * .7) {
        MyColors[i] <- 'rgb(255, 0, 0)'
      }
      else{
        MyColors[i] <- 'rgb(255, 255, 255)'
      }
    }

    output$dummy_data_table <- DT::renderDataTable(
      DT::datatable(
        myDisplayData,
        extensions = 'Buttons',
        options = list(
          pageLength = 50,
          scrollX=TRUE,
          dom = 'T<"clear">lBfrtip'
        )
      ) %>% formatStyle('B', target = 'cell', backgroundColor = styleEqual(myDisplayData$B, MyColors)) %>% 
        formatCurrency(1:2, currency = "", interval = 3, mark = ",")
    ) # close renderDataTable

  }
)

编辑-------------------------

这里是一种多列方法，它假定所有其他列都引用“ A”列：

library(shiny)
library(DT)
library(data.table)

shinyApp(
  ui = fluidPage(
    DTOutput("dummy_data_table")
  ),

  server = function(input, output) {

    myDisplayData <- data.table(replicate(15,sample(round(runif(20,0,300000)), 20, rep=TRUE)))
    names(myDisplayData) <- LETTERS[1:15]
    referenceCol <- "A"
    targetColumns <- names(myDisplayData)[!names(myDisplayData) %in% referenceCol]
    myDisplayData[, index := seq(.N)]

    rowUniqueCols <- paste0("rowUnique", targetColumns)

    for(i in seq(rowUniqueCols)){
      myDisplayData[, (rowUniqueCols[i]) := do.call(paste,c(.SD, sep = "_")), .SDcols=c("index", targetColumns[i])]
    }

    myWorkData <- melt.data.table(myDisplayData, id.vars=c("index", referenceCol), measure.vars = rowUniqueCols)
    myDisplayData[, index := NULL]
    HideCols <- which(names(myDisplayData) %in% rowUniqueCols)
    setnames(myWorkData, "value", "rowUniqueValue")
    myWorkData[, value := as.numeric(sapply(strsplit(rowUniqueValue, "_"), "[[", 2))]
    myWorkData[, variable := NULL]
    myWorkData[, colors := ifelse(value >= .SD*1.3, 'rgb(0,255,255)', 'rgb(255, 255, 255)'), .SDcols=referenceCol]
    myWorkData[colors %in% 'rgb(255, 255, 255)', colors := ifelse(value <= .SD*.7, 'rgb(255, 0, 0)', 'rgb(255, 255, 255)'), .SDcols=referenceCol]

    output$dummy_data_table <- DT::renderDataTable(
      DT::datatable(
        myDisplayData,
        extensions = 'Buttons',
        options = list(
          pageLength = 50,
          scrollX=TRUE,
          dom = 'T<"clear">lBfrtip', 
          columnDefs = list(list(visible=FALSE, targets=HideCols))
        )
      ) %>% formatStyle(columns = targetColumns, valueColumns = rowUniqueCols, target = 'cell', backgroundColor = styleEqual(myWorkData$rowUniqueValue, myWorkData$colors)) %>% 
        formatCurrency(1:15, currency = "", interval = 3, mark = ",")
    ) # close renderDataTable

  }
)

结果：

在Rshiny中显示逗号和条件突出显示-不兼容

1 个答案: