I have a Shiny app that I am working on and am using renderDataTable to display a data frame to the user. Right now, the user needs to click on a row of the table to pull up additional information about that row. At the same time, I have the data table set to be 'row' editable. This is really causing some problems. In order to initiate the edit mode for the row, one needs to double click on the row, but clicking multiple times toggles the selected state of the row.
Is there a way to initiate the row editing without having to double click or to disable the row selection status when a double click is present?
EDIT: Here is my invocation of the DT:
output$image_list = DT::renderDataTable({
if(!('data.frame' %in% class(values$images))) {
return(NULL)
}
datatable(values$images,
rowname=FALSE,
options=list(columnDefs = list(list(visible=FALSE, targets=c(0, 1, 3, 6)))),
colnames=c('ID', 'Full File Name', 'Filename', 'Directory', 'Range Scale', 'Heading', 'Status'),
selection = 'single',
editable = list(target='row', disable = list(columns=c(0, 1, 2, 3, 6)))
) %>%
formatStyle('Status', target='row', backgroundColor = styleEqual(c('Incomplete', 'Complete'), c('#FF9999', '#99FF99')))
})
Version Information
Tool | Version
-----|--------
R | 4.0
Shiny| 1.5.0
DT | 0.15
I'm not sure to understand but maybe this can help. With the app below, you can select a row only by clicking on a cell in a non-editable column. So, double-clicking an editable cell doesn't trigger the row selection. Not sure this helps... tell me what.
library(shiny)
library(DT)
dat <- iris[1:6,]
nonEditableColumns <- c(3, 4)
ui <- fluidPage(
br(),
DTOutput("dtable")
)
server <- function(input, output, session) {
output[["dtable"]] <- renderDT({
datatable(
dat,
extensions = "Select",
selection = "none",
editable = list(
target = "row",
disable = list(columns = nonEditableColumns)
),
options = list(
columnDefs = list(
list(className = "selectable", targets = nonEditableColumns),
list(className = "dt-center", targets = "_all")
),
select = list(style = "single",
selector = "td.selectable")
)
)
}, server = FALSE)
}
shinyApp(ui, server)
Related
I have a DT object embed in a Shiny app. With the code below, I am able to select one row at the time with a left click of the mouse:
library(DT)
library(shiny)
library(tidyverse)
ui <- fluidPage(
fluidRow(
column(width = 12,
DTOutput(outputId = "table",
width = "100%"))
)
)
server <- function(input, output, session) {
output$table <- renderDT({
datatable(data = iris,
selection = "single",
rownames = FALSE,
escape = FALSE,
extension = "KeyTable",
options = list(pageLength = 10,
autoWidth = FALSE,
scrollX = TRUE,
keys = TRUE,
columnDefs = list(list(
targets = 4,
render = JS(
"function(data, type, row, meta) {",
"return type === 'display' && data != null && data.length > 125 ?",
"'<span title=\"' + data + '\">' + data.substr(0, 125) + '...</span>' : data;",
"}")
))),
class = "display")
})
}
shinyApp(ui = ui,
server = server)
However, I would like to obtain the same result with the UP and DOWN arrow of the keyboard. In this way, I can select (and automatically deselect) a row only through these two buttons, which is useful when the table is pretty long and there are lots of rows to check. Thanks for your help!
EDIT: I've modified the code to insert the extension "KeyTable" as suggested by silentdevildoll. Although I can move in the table's cells with the keyboard, I am still not able to select them with the UP and DOWN arrow.
combined and adapted from different sources but mainly https://laustep.github.io/stlahblog/posts/DTcallbacks.html#select-rows-on-click-and-drag
Key points:
you need the event key-focus, which is the event triggered because KeyTable already handles the arrow keys to move on the grid.
in contrast, key would only handle events that are not handled by key-focus or other built-in KeyTable functionality. https://datatables.net/reference/event/#keytable
You need server=FALSE in the renderDT call. If you use server-side handling, the indexes will be incorrect if there has been any sorting applied.
Shiny complains about the Select extension which apparently clashes with Shiny's select functionality. However it seems to be working fine. I just overwrite the existing {outputname}_rows_selected input so the latest entry wins, both click and arrow row selection work.
Not sure how to better handle initial clicking; it can be that you have to click on the table twice before the keys get activated (seen by the blue highlight on the selected cell)
library(shiny)
library(DT)
js_select_dt <- c(
"var dt = table.table().node();",
"var tblID = $(dt).closest('.datatables').attr('id');",
"var inputName = tblID + '_rows_selected'",
"var incrementName = tblID + '_rows_selected2_increment'",
"table.on('key-focus', function(e, datatable, cell, originalEvent){",
" if (originalEvent.type === 'keydown'){",
" table.rows().deselect(); ",
" table.row(cell[0][0].row).select();",
" row = table.rows({selected: true})",
# Note: this ID is zero-based so add one
" Shiny.setInputValue(inputName, [parseInt(row[0]) + 1]);",
" }",
"});"
)
ui <- fluidPage(
textOutput("selectedRow"),
DT::DTOutput("irisTable")
)
server <- function(input, output) {
output$irisTable<- DT::renderDT({
iris %>%
datatable(
# This datatable uses both shiny's select for conventional selection
# and keytable + select for selection by keyboard (callback js_select_dt, see above).
# The keyboard-selected row just overwrites the regular input$peaksTable_rows_selected
# field.
selection = "single",
editable = FALSE,
callback = JS(js_select_dt),
extensions = c("KeyTable", "Select"),
options = list(
keys = TRUE,
# keys = list(keys = c(38, 40))
select = TRUE
)
)
}, server=FALSE)
output$selectedRow <- renderText(input$irisTable_rows_selected)
}
runApp(shinyApp(ui, server))
I have a table made with the DT package where my cells are clickable. However, I would like to have the cells in the row names not clickable or in other word, specify a range of columns, something like ‘selected = [2:5]’ where cells are actually active for a click base behavior.
Hope the problem is quiet enough visual. Thanks for your help.
You mean the click for the selection ? The code below works for me but I'm not using the latest version of DT.
output$dtable <- renderDT({
datatable(iris, extensions = "Select", selection = "none",
options = list(
columnDefs = list(
list(className = "not-selectable", targets = 0)
),
select = list(
style = "single",
selector = "td:not(.not-selectable)"
)
)
)
})
I have a example shiny app here. It displays editable datatable using DT package.
To enable downloading all data shown on multiple pages, I use server=FALSE together with renderDT.
What I want to achieve now is
restrict user to edit some specific columns.
The following code does not seem to work.
editable = list(target = 'cell', disable = list(column = c("Sepal.Length", "Sepal.Width")))
I want to specify a default file name when exporting to csv, something like data.csv. Is that possible?
Super appreciate it if someone can help me out on that. Thanks a lot.
library(shiny)
library(DT)
library(dplyr)
# UI
ui = fluidPage(
selectInput("nrows",
"select n entries",
choices = 100:150,
selected = 100,
multiple = FALSE),
DT::dataTableOutput('tbl'),
checkboxGroupInput('datacols',
label='Select Columns:',
choices= c('Sepal.Length', 'Sepal.Width', 'Petal.Length', 'Petal.Width', 'Specie'),
selected = c('Sepal.Length', 'Sepal.Width', 'Petal.Length', 'Petal.Width', 'Specie'),
inline=TRUE )
)
# SERVER
server = function(input, output) {
df = reactiveValues()
observe ({
df$dat = iris %>% .[1:input$nrows, ]
})
# render DT
output$tbl = renderDT(server=FALSE, {
datatable(df$dat %>% select(one_of(input$datacols)),
editable = list(target = 'cell', disable = list(column = c("Sepal.Length", "Sepal.Width"))), #"cell",
extensions = "Buttons",
options = list(
dom = "Bfrtip", buttons = list("csv")))
})
observeEvent(input[["tbl_cell_edit"]], {
cellinfo <- input[["tbl_cell_edit"]]
df$dat <- editData(df$dat, input[["tbl_cell_edit"]])
})
}
shinyApp(ui=ui, server = server)
To disable some columns for editing, you have to give the column indices, not the column names. Moreover the key word is columns, not column:
editable = list(target = 'cell', disable = list(columns = c(1,2)))
To specify the file name, do:
buttons = list(
list(extend = "csv", text = "Export to CSV", filename = "iris")
)
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)
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)
Is there a way to have the selected row(s) in a shiny datatable (DT) be available for the user to copy (Ctrl+C) to their clipboard. Ideally it would also supply the data table's column names or headers.
UPDATE
global.R
library(rclipboard)
library(shiny)
ui.R:
...
rclipboardSetup(),
...
uiOutput("copy"),
server.R:
output$copy = renderUI({
s = input$orders_rows_selected
rclipButton("copybtm","Copy",data()[s,],icon("clipboard"))
})
Here is how to get a button to copy the selected rows. And there are the column headers too.
datatable(
iris,
rownames = FALSE,
extensions = c("Buttons", "Select"),
options =
list(
select = TRUE,
dom = "Bfrtip",
buttons = list(
list(
extend = "copy",
text = 'Copy',
exportOptions = list(modifier = list(selected = TRUE))
)
)
)
)