Shiny: Using selections from timevis to highlight rows in data table - r

Question

I am building a shiny app with a timeline and a data table. What I would like to have happen is when the user clicks on an item in the timeline, the corresponding data in the table is highlighted.
I have come up with a solution for this, but it seems very hacky and R is giving me warning messages. Basically what I have done is created a flag in the data table that is 1 if that item is selected and 0 if it's not, then I format the row based on that flag. When I create the "selected" field, I get a warning because initially nothing is selected and mutate doesn't like the fact that input$timeline_selected is NULL. Also for some reason when I try to add the rownames = FALSE argument to datatable all the data in the table is filtered out (not sure what is happening there).
Anyway, I'm wondering if there is a better way to do this perhaps with HTML or CSS. I've tried looking, but I can't figure out how to do it.
Eventually I would also like to know how to highlight the rows in the data table if the user hovers over the item in the timeline rather than selects it.
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

Using Your Code
Your method certainly works -- it's similar to this answer. You could prevent some of the error messages by using if...else and a validation statment:
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"))
)
}
})
I believe your issue with adding rownames = FALSE is because columnDefs uses JS indexing instead of R indexing. R indexes start at 1, whereas JS indexes start at 0.
When rownames = TRUE, your table has column indexes 0-5, where rownames is column 0 and selected is the column 5. So columnDefs works. However, when rownames = FALSE, you only have column indexes 0-4, so targets = 5 is outside the index range of your table. If you change your code to targets = 4, then you will again be specifying the selected column in columnDefs.
Other Options
Here's two other options using JS:
Generate the table on the server-side, as based on this answer. This may be a better option for large data objects.
Generate the table on the client-side as based on this answer. With a smaller object, this seems to update more smoothly.
An example app with both tables is below.
Example Code
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)