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，那么您将再次在selected中指定columnDefs列。

其他选项

以下是使用JS的其他两个选项：

根据this answer在服务器端生成表格。这可能是better option for large data objects。
根据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)

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

1 个答案:

使用您的代码

其他选项

示例代码