R Shiny：renderUI 中的表格条件格式

Question

在另一个post 中，假设该表不是renderUI 函数的一部分，已回答了相同的问题。

在下面的示例中，我正在尝试调整相同的解决方案（使用 JQuery），其中我想要有条件地格式化的表属于 renderUI 函数。

    library(shiny)
    library(datasets)

    script <- "$('tbody tr td:nth-child(5)').each(function() {

              var cellValue = $(this).text();

              if (cellValue > 50) {
                $(this).css('background-color', '#0c0');
              }
              else if (cellValue <= 50) {
                $(this).css('background-color', '#f00');
              }
            })"

  shinyServer(function(input, output, session) {

    session$onFlushed(function() {
      session$sendCustomMessage(type='jsCode', list(value = script))
    })

    output$view <- renderTable({
      head(rock, n = 20)
    })

    output$Test1 <- renderUI({
      list(
        tags$head(tags$script(HTML('Shiny.addCustomMessageHandler("jsCode", function(message) { eval(message.value); });'))),
        tableOutput("view")
      )
    })
  })

  shinyUI(fluidPage(

    tabsetPanel(
      tabPanel("Test1",uiOutput("Test1")),
      tabPanel("Test2")
    )
  ))

在这个小例子中，条件格式不应用于表格

Answer 1

谢谢，jdharrison - this 非常完美。

我从this jQuery thread 借用了一些方法来扩展该方法，以根据预定义的最小值和最大值创建单元格的渐变着色（例如数据表热图）。希望此修改对某人有所帮助。

使用您的独立示例：

library(shiny)
library(datasets)
script <- "
// Set min and max for gradient

var min = 0;
var max = 100;
var n = max-min

// Define the min colour, which is white
    xr = 255; // Red value
    xg = 255; // Green value
    xb = 255; // Blue value

// Define the max colour #2ca25f
    yr = 44; // Red value
    yg = 162; // Green value
    yb = 95; // Blue value


$('tbody tr td:nth-child(5)').each(function() {
var val = parseInt($(this).text());

// Catch exceptions outside of range
if (val > max) {
  var val = max;
}

else if (val < min) {
  var val = min;
}

// Find value's position relative to range

var pos = ((val-min) / (n-1));

// Generate RGB code
red = parseInt((xr + (( pos * (yr - xr)))).toFixed(0));
green = parseInt((xg + (( pos * (yg - xg)))).toFixed(0));
blue = parseInt((xb + (( pos * (yb - xb)))).toFixed(0));

clr = 'rgb('+red+','+green+','+blue+')';

// Apply to cell

$(this).css('background-color', clr);

})"

runApp(list(server = function(input, output, session) {
  session$onFlushed(function() {
    session$sendCustomMessage(type='jsCode', list(value = script))
  }, FALSE)
  output$view <- renderTable({
    head(rock, n = 20)
  })
  output$Test1 <- renderUI({
    list(
      tags$head(tags$script(HTML('Shiny.addCustomMessageHandler("jsCode", function(message) { eval(message.value); });')))
      , tableOutput("view")
    )
  })
  }
  , ui = fluidPage(

    tabsetPanel(
      tabPanel("Test1",uiOutput("Test1")),
      tabPanel("Test2")
    )
  ))
  )

输出

Answer 2

将您的调用更改为session$onFlushed 以在每次shiny 通过添加参数once = FALSE 刷新反应系统时调用您的函数：

  session$onFlushed(function() {
    session$sendCustomMessage(type='jsCode', list(value = script))
  }, once = FALSE)

在一个独立的例子中：

library(shiny)
library(datasets)
script <- "$('tbody tr td:nth-child(5)').each(function() {
var cellValue = $(this).text();
if (cellValue > 50) {
$(this).css('background-color', '#0c0');
}
else if (cellValue <= 50) {
$(this).css('background-color', '#f00');
}
})"
runApp(list(server = function(input, output, session) {
  session$onFlushed(function() {
    session$sendCustomMessage(type='jsCode', list(value = script))
  }, FALSE)
  output$view <- renderTable({
    head(rock, n = 20)
  })
  output$Test1 <- renderUI({
    list(
      tags$head(tags$script(HTML('Shiny.addCustomMessageHandler("jsCode", function(message) { eval(message.value); });')))
      , tableOutput("view")
    )
  })
}
, ui = fluidPage(

  tabsetPanel(
    tabPanel("Test1",uiOutput("Test1")),
    tabPanel("Test2")
  )
))
)