R语言 基于DataTableOutput中的标志突出显示特定单元格

bihw5rsg  于 12个月前  发布在  其他
关注(0)|答案(1)|浏览(80)

我想在DataTableOutput中突出显示特定的单元格(不是整列或整行),其中数据以宽格式显示,标志信息以长格式显示。我尝试使用相应的矩阵(具有TRUE/TRUE值)和JS回调来实现这一点,但被卡住了。我也试图在stackoverflow上找到类似的方法,但不幸的是没有成功。
以下是我目前为止的代码:

library(shiny)
library(DT)
library(dplyr)
library(jsonlite)

# Sample long_data
long_data <- data.frame(
  id = rep(1:7, each = 10),
  year = rep(2011:2020, times = 7),
  value = rnorm(70),  # Example values
  flag = sample(c(TRUE, FALSE), 70, replace = TRUE)  # Example flag values
)

# Convert to wide format
wide_data <- reshape(long_data %>% select(-flag), idvar = "id", timevar = "year", direction = "wide")

# Create a matrix for flags
flag_matrix <- matrix(long_data$flag, nrow = 7, byrow = TRUE)
colnames(flag_matrix) <- paste0("value.", 2011:2020)  # Ensure these match wide_data column names
flag_matrix <- cbind(FALSE, flag_matrix)  # Adding an extra FALSE column to align with wide_data

ui <- fluidPage(
  # Include the flag matrix as a JavaScript variable
  tags$script(HTML(paste0("var flag_matrix = ", jsonlite::toJSON(flag_matrix, array = TRUE), ";"))),
  
  DTOutput("table")
)

server <- function(input, output, session) {
  output$table <- renderDT({
    datatable(wide_data,
              options = list(
                pageLength = 5, autoWidth = TRUE
              ), callback = JS(
                'function(settings, json) {
        var api = this.api();
        api.cells().every(function(){
          var cell = this;
          var rowIdx = cell.index().row;
          var colIdx = cell.index().column;

          // Check flag for the current cell
          if (flag_matrix[rowIdx][colIdx]) {
            $(cell.node()).css({"background-color": "lightblue", "font-weight": "bold"});
          }
        });
      }'
              )
    )
  })
}

shinyApp(ui, server)

字符串
不幸的是,这个回调不会得到任何输出

ffx8fchx

ffx8fchx1#

function(settings, json){ ... }drawCallback选项,而不是callback

library(shiny)
library(DT)
library(dplyr)
library(jsonlite)

# Sample long_data
long_data <- data.frame(
  id = rep(1:7, each = 10),
  year = rep(2011:2020, times = 7),
  value = rnorm(70),  # Example values
  flag = sample(c(TRUE, FALSE), 70, replace = TRUE)  # Example flag values
)

# Convert to wide format
wide_data <- reshape(long_data %>% select(-flag), idvar = "id", timevar = "year", direction = "wide")

# Create a matrix for flags
flag_matrix <- matrix(long_data$flag, nrow = 7, byrow = TRUE)
colnames(flag_matrix) <- paste0("value.", 2011:2020)  # Ensure these match wide_data column names
flag_matrix <- cbind(FALSE, flag_matrix)  # Adding an extra FALSE column to align with wide_data

ui <- fluidPage(
  # Include the flag matrix as a JavaScript variable
  tags$script(HTML(paste0("var flag_matrix = ", jsonlite::toJSON(flag_matrix, array = TRUE), ";"))),
  
  DTOutput("table")
)

server <- function(input, output, session) {
  output$table <- renderDT({
    datatable(
      wide_data,
      options = list(
        pageLength = 5, 
        autoWidth = TRUE,
        drawCallback = JS(
          'function(settings, json) {
        var api = this.api();
        api.cells().every(function(){
          var cell = this;
          var rowIdx = cell.index().row;
          var colIdx = cell.index().column;

          // Check flag for the current cell
          if (flag_matrix[rowIdx][colIdx]) {
            $(cell.node()).css({"background-color": "lightblue", "font-weight": "bold"});
          }
        });
      }'
        )
      )
    )
  })
}

shinyApp(ui, server)

字符串

相关问题