Shiny：使用 timevis 中的选择突出显示数据表中的行

Question

我正在构建一个带有时间线和数据表的闪亮应用。我希望发生的是当用户单击时间轴中的某个项目时，表格中的相应数据会突出显示。

我已经为此提出了一个解决方案，但它看起来很hacky，R 正在给我警告信息。基本上我所做的是在数据表中创建一个标志，如果该项目被选中，则为 1，如果未选中，则为 0，然后我根据该标志格式化行。当我创建“selected”字段时，我收到一个警告，因为最初没有选择任何内容，并且 mutate 不喜欢 input$timeline_selected 为 NULL 的事实。同样由于某种原因，当我尝试将rownames = FALSE 参数添加到datatable 时，表中的所有数据都被过滤掉了（不确定那里发生了什么）。

无论如何，我想知道是否有更好的方法可以使用 HTML 或 CSS 来做到这一点。我已经尝试过寻找，但我不知道该怎么做。

最后我还想知道如果用户将鼠标悬停在时间轴中的项目上而不是选择它，如何突出显示数据表中的行。

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

dataBasic <- data.frame(
  id = 1:4,
  content = c("Item one", "Item two" ,"Ranged item", "Item four"),
  start   = c("2016-01-10", "2016-01-11", "2016-01-20", "2016-02-14"),
  end    = c(NA, NA, "2016-02-04", NA)
)



ui <- fluidPage(
  column(wellPanel(timevisOutput("timeline")
                   ), width = 7
         ),
  column(wellPanel(dataTableOutput(outputId = "table")
                   ), width = 5)
  )

server <- function(input, output){
  # Create timeline
  output$timeline <- renderTimevis({
    config <- list(
      orientation = "top",
      multiselect = TRUE
    )
      timevis(dataBasic, options = config)
  })


  output$table <- DT::renderDataTable({
    input$timeline_data %>% 
      mutate(selected = if_else(id %in% input$timeline_selected, 1, 0)) %>% 
      datatable(options = list(pageLength = 10, 
                               columnDefs = list(list(targets = 5, visible = FALSE))
                               )
       ) %>% 
       formatStyle("selected", target = "row", backgroundColor = styleEqual(c(0, 1), c("transparent", "#0092FF"))
       )
  })

}
shinyApp(ui = ui, server = server)

Answer 1

使用您的代码

你的方法确实有效——它类似于this answer。您可以通过使用if...else 和validation 声明来防止某些错误消息：

output$table <- DT::renderDataTable({

        validate(need(!is.null(input$timeline_data), ""))

        if(is.null(input$timeline_selected)) {
            input$timeline_data %>%
                datatable(
                    rownames = FALSE,
                    options = list(pageLength = 10))
        } else {
            input$timeline_data %>% 
                mutate(selected = if_else(id %in% input$timeline_selected, 1, 0)) %>% 
                datatable(rownames = FALSE, 
                          options = list(pageLength = 10, 
                                         columnDefs = list(list(targets = 4, visible = FALSE))
                )
                ) %>% 
                formatStyle("selected", target = "row", backgroundColor = styleEqual(c(0, 1), c("transparent", "#0092FF"))
                ) 
        }
    })

我相信您添加rownames = FALSE 的问题是因为columnDefs 使用JS indexing instead of R indexing。 R 索引从 1 开始，而 JS 索引从 0 开始。

当rownames = TRUE 时，您的表的列索引为0-5，其中rownames 是第0 列，selected 是第5 列。所以columnDefs 有效。但是，当rownames = FALSE 时，您只有0-4 列索引，因此targets = 5 超出了表的索引范围。如果您将代码更改为targets = 4，那么您将再次在columnDefs 中指定selected 列。

其他选项

这里有另外两个使用 JS 的选项：

1. 在服务器端生成表，基于this answer。这可能是better option for large data objects。
2. 根据this answer 在客户端生成表。使用更小的对象，这似乎更新更顺利。

下面是一个包含两个表的示例应用程序。

示例代码

library(shiny)
library(DT)
library(dplyr)
library(timevis)

dataBasic <- data.frame(
    id = 1:4,
    content = c("Item one", "Item two" ,"Ranged item", "Item four"),
    start = c("2016-01-10", "2016-01-11", "2016-01-20", "2016-02-14"),
    end = c(NA, NA, "2016-02-04", NA)
)

ui <- fluidPage(
    column(wellPanel(timevisOutput("timeline")
    ), width = 7
    ),
    column(
        wellPanel(
            h3("Client-Side Table"),
            DT::dataTableOutput("client_table"),
            h3("Server-Side Table"),
            DT::dataTableOutput("server_table")
    ), width = 5)
)

server <- function(input, output, session){

    # Create timeline
    output$timeline <- renderTimevis({
        config <- list(
            orientation = "top",
            multiselect = TRUE
        )
        timevis(dataBasic, options = config)
    })

    ## client-side ##
    # based on: https://stackoverflow.com/a/42165876/8099834
    output$client_table <- DT::renderDataTable({
        # if timeline has been selected, add JS drawcallback to datatable
        # otherwise, just return the datatable
        if(!is.null(input$timeline_selected)) {
            # subtract one: JS starts index at 0, but R starts index at 1
            index <- as.numeric(input$timeline_selected) - 1
            js <- paste0("function(row, data) {
                $(this
                     .api()
                     .row(", index, ")
                     .node())
                .css({'background-color': 'lightblue'});}")
            datatable(dataBasic,
                      rownames = FALSE,
                      options = list(pageLength = 10,
                                     drawCallback=JS(js)))
        } else {
            datatable(dataBasic,
                      rownames = FALSE,
                      options = list(pageLength = 10))
        }

    }, server = FALSE)

    ## server-side ##
    # based on: https://stackoverflow.com/a/49176615/8099834
    output$server_table <- DT::renderDataTable({

        # create the datatable
        dt <- datatable(dataBasic,
                        rownames = FALSE,
                        options = list(pageLength = 10))

        # if timeline has been selected, add row background colors with formatstyle
        if(!is.null(input$timeline_selected)) {
            index <- as.numeric(input$timeline_selected)
            background <- JS(paste0("value == '",
                                    index,
                                    "' ? 'lightblue' : value != 'else' ? 'white' : ''"))
            dt <- dt %>%
                formatStyle(
                    'id',
                    target = 'row',
                    backgroundColor = background)
        }

        # return the datatable
        dt
    })
}
shinyApp(ui = ui, server = server)