R DT Shiny KeyTable select cell/row with Enter - r

In R, the DT KeyTable extension allows to move around the cells with arrow keys.
Is it possible to select the current cell with Enter instead of a mouse click?
Thank you in advance.
library(shiny)
library(DT)
library(datasets)
df <- datasets::mtcars
# Define UI for application that draws a histogram
ui <- fluidPage(
DTOutput('table'), HTML("<br>"),
textOutput('selected')
)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$table <- renderDT(
df,
selection = 'single',
extensions = 'KeyTable',
options = list(
dom = 't',
keys = TRUE
)
)
output$selected <- renderText({
print(rownames(df)[input$table_rows_selected])
})
}
# Run the application
shinyApp(ui = ui, server = server)

To select cells:
library(shiny)
library(DT)
js <- c(
"table.on('key', function(e, datatable, key, cell, originalEvent){",
" if(key == 13){",
" cell.select();",
" }",
"});"
)
ui <- fluidPage(
DTOutput('table'),
br(),
verbatimTextOutput('selected')
)
server <- function(input, output) {
output$table <- renderDT(
iris,
selection = 'none',
extensions = c("KeyTable", "Select"),
callback = JS(js),
options = list(
dom = 't',
keys = TRUE,
select = list(style = "multi", items = "cell")
),
server = FALSE
)
output$selected <- renderPrint({
input$table_cells_selected
})
}
# Run the application
shinyApp(ui = ui, server = server)
If you also want to deselect:
js <- c(
"table.on('key', function(e, dt, key, cell, originalEvent){",
" if(key == 13){",
" var selected = dt.cells({selected: true});",
" var indices = selected.indexes().toArray().map(JSON.stringify);",
" if(indices.indexOf(JSON.stringify(cell.index())) === -1) {",
" cell.select();",
" } else {",
" cell.deselect();",
" }",
" }",
"});"
)

Related

Getting onClcik to work in a Shiny App when user clicks on a cell in a table

I am trying to build a Shiny App and get the onClick function to output the cell row/column the user clicked on.
How can I fix the code to display the cell row/column?
Shiny App
library(reactable)
library(shiny)
library(htmlwidgets)
iris = iris
ui <- fluidPage(
reactable::reactableOutput("irisTABLE"),
textOutput("'cellDATA")
)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$irisTABLE = renderReactable({
reactable(iris,
onClick = JS("
function(rowInfo, colInfo) {
Shiny.setInputValue('cell_data', colInfo.id + '-' + rowInfo.row.CapRate, { priority: 'event' })
}
")
)
})
output$cellDATA = renderText({
paste0("The cell selected is: ", input$cell_data)
})
}
# Run the application
shinyApp(ui = ui, server = server)
Change theoutput$cellDATA to
if (!is.null(input$cell_data)) { row_col <- strsplit(input$cell_data, "-") paste0("The cell selected is in row ", row_col[[1]][2], " and column ", row_col[[1]][1]) }
library(reactable)
library(shiny)
iris = iris
ui <- fluidPage(
reactable::reactableOutput("irisTABLE"),
textOutput("cellDATA")
)
server <- function(input, output) {
output$irisTABLE = renderReactable({
reactable(iris,
onClick = JS("
function(rowInfo, colInfo, e) {
Shiny.setInputValue('cell_data', colInfo.id + '-' + rowInfo.index)
}
")
)
})
output$cellDATA = renderText({
if (!is.null(input$cell_data)) {
row_col <- strsplit(input$cell_data, "-")
paste0("The cell selected is in row ", row_col[[1]][2], " and column ", row_col[[1]][1])
}
})
}
shinyApp(ui = ui, server = server)

Shiny DT datatable selectInput with reactive data

I recently asked a similar question (Shiny DT datatable input reactivity after table is reloaded). My issue was getting a selectInput in a DT datatable to work correctly after the table is reloaded. The solution worked, which was to use javascript to unbind before reloading the table. However, that example used a static dataframe. When the input data in the datatable are reactive, it doesn't work. In the example below, when the user clicks "Update data" the first time to load data, the selectInput works correctly and input$id1 responds to the user selection. However, when the user clicks "Update data" again to update the reactive data, the input$id no longer responds to the user selection. I've seen two potential approaches to address the issue. One is using dataTableProxy() and replaceData(), and the other is renaming the selectInput ids each time the reactive data are updated. I was wondering if I can avoid those two approaches and get this example working with minimal changes.
require(shiny)
require(DT)
shinyApp(
ui = fluidPage(
tags$head(tags$script(
HTML(
"Shiny.addCustomMessageHandler('unbindDT', function(id) {
var $table = $('#'+id).find('table');
if($table.length > 0){
Shiny.unbindAll($table.DataTable().table().node());
}
})")
)),
actionButton(inputId = "update", label = "Update data"),
uiOutput("resettable_table")
),
server = function(input, output, session) {
rv <- reactiveValues(
times = 1,
mydata = NULL
)
observeEvent(input$update, {
session$sendCustomMessage("unbindDT", "mytable")
rv$times <- rv$times + 1
rv$mydata <- data.frame(
Col1 = as.character(selectInput(
inputId = "id1",
label = NULL,
choices = paste0(letters, input$update),
selected = paste0(letters, input$update)[1],
))
)
})
output$mytable <- DT::renderDataTable({
req(rv$mydata)
DT::datatable(
data = rv$mydata,
escape = F,
selection = "none",
options = list(
preDrawCallback = JS('function(){Shiny.unbindAll(this.api().table().node());}'),
drawCallback = JS('function(){Shiny.bindAll(this.api().table().node());}')
)
)
}, server = F)
output$resettable_table <- renderUI({
req(rv$times)
div(
id = paste0("mydiv", rv$times),
DT::dataTableOutput("mytable")
)
})
observe({
if(is.null(input$id1)) {
print("input$id1 is NULL")
} else {
print(paste(c("input$id1:", input$id1)))
}
})
}
)
Update
Thanks to #StephaneLaurent for pointing out that the reactive counter keeping track of the number of times the data were reloaded was causing the issue. It wasn't actually necessary to put the DT datatable inside a div with an id that updated each time. Here is working code:
require(shiny)
require(DT)
shinyApp(
ui = fluidPage(
tags$head(tags$script(
HTML(
"Shiny.addCustomMessageHandler('unbindDT', function(id) {
var $table = $('#'+id).find('table');
if($table.length > 0){
Shiny.unbindAll($table.DataTable().table().node());
}
})")
)),
actionButton(inputId = "update", label = "Update data"),
DT::dataTableOutput("mytable")
),
server = function(input, output, session) {
rv <- reactiveValues(mydata = NULL)
observeEvent(input$update, {
session$sendCustomMessage("unbindDT", "mytable")
rv$mydata <- data.frame(
Col1 = as.character(selectInput(
inputId = "id1",
label = NULL,
choices = paste0(letters, input$update),
selected = paste0(letters, input$update)[1],
))
)
})
output$mytable <- DT::renderDataTable({
req(rv$mydata)
DT::datatable(
data = rv$mydata,
escape = F,
selection = "none",
options = list(
preDrawCallback = JS('function(){Shiny.unbindAll(this.api().table().node());}'),
drawCallback = JS('function(){Shiny.bindAll(this.api().table().node());}')
)
)
}, server = F)
observe({
if(is.null(input$id1)) {
print("input$id1 is NULL")
} else {
print(paste(c("input$id1:", input$id1)))
}
})
}
)
The problem is caused by the presence of rv$times in the renderUI. The simplest way to make this app work is to get rid of this renderUI.
However, for fun, and in order to understand what happens, I did the app below which works with the renderUI and which shows what happens. The key point was to remove the id1 element when the table is consecutively rendered two times, before the second rendering. To do so, I use a JavaScript counter i.
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
tags$head(tags$script(
HTML("var i = 1;")
)),
actionButton(inputId = "update", label = "Update data"),
uiOutput("resettable_table")
),
server = function(input, output, session) {
rv <- reactiveValues(
times = 1,
mydata = NULL
)
observeEvent(input$update, {
rv$times <- rv$times + 1
rv$mydata <- data.frame(
Col1 = as.character(selectInput(
inputId = "id1",
label = NULL,
choices = paste0(letters, input$update),
selected = paste0(letters, input$update)[1],
))
)
})
output$mytable <- DT::renderDataTable({
req(rv$mydata)
DT::datatable(
data = rv$mydata,
escape = F,
selection = "none",
options = list(
initComplete = JS('function(settings) { alert("initComplete - incrementing i"); i++; alert("i = " + i)}'),
preDrawCallback = JS('function() { alert("preDrawCallback triggered - unbinding"); Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { alert("drawCallback triggered - i = " + i); if(i===2) {alert("removing id1 and resetting i to 0"); $("#id1").remove(); i=0;} Shiny.bindAll(this.api().table().node());}')
)
)
}, server = F)
output$resettable_table <- renderUI({
div(
id = paste0("mydiv", rv$times),
tags$p(paste0("mydiv", rv$times)),
DT::dataTableOutput("mytable")
)
})
observe({
if(is.null(input$id1)) {
print("input$id1 is NULL")
} else {
print(paste(c("input$id1:", input$id1)))
}
})
}
)

Preserve selectizeInput selection in text box after actionButton is used

Default ordering is: Item1, Item2, Item3. If I select a new order and click Update, my selection disappears, but the output table is correct.
How do I preserve my selection so that it shows up like so even after Update is clicked?
library(shiny)
shinyApp(
ui = shinyUI({
fluidPage(
sidebarLayout(
sidebarPanel(uiOutput("selection"),
actionButton('update',"Update")),
mainPanel(
tableOutput('ordered')
)
)
)
}),
server = function(input, output, session) {
values <- reactiveValues(x = c('Item1','Item2','Item3'))
output$selection <- renderUI({
selectizeInput('neworder',
'Select order:',
choices = values$x,
selected = preserve$selection,
multiple = TRUE,
options = list(plugins = list('remove_button', 'drag_drop')))
})
output$ordered <- renderTable(
values$x
)
preserve <- reactiveValues(selection = character())
observeEvent(input$neworder,{
if (!all(preserve$selection %in% input$neworder)) {
preserve$selection = input$neworder
}
})
observeEvent(input$update,{
id <- values$x %in% input$neworder
values$x <- c(input$neworder, values$x[!id])
})
}
)
You can use isolate() to avoid unwanted update:
selectizeInput('neworder',
'Select order:',
choices = isolate(values$x),
selected = preserve$selection,
multiple = TRUE,
options = list(plugins = list('remove_button', 'drag_drop')))

SelectInput for Every Row of the table in Shiny

I have a table that has three columns and variable number of rows. I want to create a column such that every row of the new column contains a selectInput with a value of Yes/No.
In a nut shell , how do i automatically generate selectInput equal to the number of rows in my table
Here is a simple code:
library(shiny)
library(rhandsontable)
ui <- fluidPage(
tableOutput('Simpletable')
)
server <- function(input,output,session)({
data <- data.frame(c1=c(5,10,15), c2=c(3,6,9) , diff=c(0,0,0), select= as.logical( c(FALSE,FALSE,FALSE)))
output$Simpletable <- renderTable(
data
)
})
shinyApp(ui = ui, server = server)
for this table, three selectInputs should appear alongside the table
Is this possible ?
Thanks
Here is a solution using library(DT) - we need to set escape = FALSE:
library(shiny)
library(DT)
library(data.table)
myTable <- data.table(c1=c(5,10,15), c2=c(3,6,9) , diff=c(0,0,0))
myTable[, row_id := paste0("row_select_", .I)][, select := as.character(selectInput(inputId=row_id, label=NULL, choices=c(yes=TRUE, no=FALSE))), by = row_id]
ui <- fluidPage(
dataTableOutput('myTableOutput'),
htmlOutput("mySelection")
)
server <- function(input, output, session){
output$myTableOutput <- DT::renderDataTable({
datatable(myTable, escape = FALSE, options = list(
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); }')
))
})
output$mySelection <- renderUI({
HTML(paste0(myTable$row_id, ": ", lapply(myTable$row_id, function(x){input[[x]]}), collapse = "<br>"))
})
}
shinyApp(ui = ui, server = server)
If you need to re-render the table (when using Shiny.bindAll) please see this related post.
Edit: Here is how to incorporate the user inputs in the table as requested by #Fahadakbar.
library(shiny)
library(DT)
library(data.table)
myTable <- data.table(c1=c(5,10,15), c2=c(3,6,9) , diff=c(0,0,0))
myTable[, row_id := paste0("row_select_", .I)][, select := as.character(selectInput(inputId=row_id, label=NULL, choices=c(yes=TRUE, no=FALSE))), by = row_id][, diff := c1-c2]
ui <- fluidPage(
dataTableOutput('myTableOutput'),
htmlOutput("mySelection")
)
server <- function(input, output, session){
output$myTableOutput <- DT::renderDataTable({
datatable(myTable, escape = FALSE, options = list(
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); }')
))
})
output$mySelection <- renderUI({
HTML(paste0(myTable$row_id, ": ", lapply(myTable$row_id, function(x){input[[x]]}), collapse = "<br>"))
})
myReactiveTable <- reactive({
myTable[, selected := as.logical(unlist(lapply(row_id, function(x){input[[x]]})))]
if(is.null(myTable$selected)){
myTable[, diff := NA_real_][, selected := NULL]
} else {
myTable[, diff := fifelse(selected, yes = c1-c2, no = NA_real_)][, select := as.character(selectInput(inputId=row_id, label=NULL, choices=c(yes=TRUE, no=FALSE), selected = input[[row_id]])), by = row_id][, selected := NULL]
}
})
myTableProxy <- dataTableProxy("myTableOutput", session)
observeEvent(myReactiveTable(), {
replaceData(myTableProxy, data = myReactiveTable(), resetPaging = FALSE)
})
}
shinyApp(ui = ui, server = server)
Also see my related answer here.

Save state of input shiny

Is there good way to save state( dont reset ) of shinyinput which generated on server side?
Example
ui=shinyUI(fluidPage(
selectInput("select","",choices = c(1,2),multiple = T),
uiOutput("din_ui")
))
server=function(input, output,session) {
output$din_ui=renderUI({
lapply(input$select,function(i){
numericInput(inputId = paste0("num_",i),i,"")
})
})
}
shinyApp(ui,server)
If i select 1 in select insert some values into num_1 than add 2 in select than num_1 reset to start value.
You can read the numericInput value, and set the control value at control init. See code:
library(shiny)
ui=shinyUI(fluidPage(
selectInput("select","",choices = c(1,2),multiple = T),
uiOutput("din_ui")
))
server=function(input, output,session) {
output$din_ui=renderUI({
input$select
isolate(
lapply(X = input$select,
FUN = function(i){
cn <- paste0("num_",i)
numericInput(inputId = cn,
label = i,
value = ifelse(!is.null(input[[cn]]), input[[cn]], ''))
}
)
)
})
}
shinyApp(ui,server)
Also find other way using insertUI ( shiny version >=14)
ui=shinyUI(fluidPage(
selectInput("select","",choices = c(1,2),multiple = T),
div(id="din_2")
))
server=function(input, output,session) {
sel_dat=reactiveValues(sel=NULL)
observeEvent(input$select,{
to_add=input$select[!input$select%in%sel_dat$sel]
for ( i in to_add){
insertUI(
selector = '#din_2',
where = "beforeEnd",
ui =numericInput(inputId = paste0("num_",i),i,"")
)
}
to_remove=sel_dat$sel[which(!sel_dat$sel %in% input$select)]
if(length(to_remove)>0){
removeUI(selector = paste0('div:has(>#num_',to_remove,")"))
}
sel_dat$sel=input$select
},ignoreNULL = FALSE)
}

Resources