I have a first DT table oTable with cell selection enabled. When the user click (select) a cell, that will generate another DT table nTable.
Then, in nTable I want to insert a selectInput. The code below is a working example. Mostly adapted from this post.
Problem:
When nTable is regenerated, the connection (binding?) with shinyValue is somehow broken.
Step to reproduce the problem:
launch the app.
select top left cell (e.g. Sepal.Length=5.1). In fact, select any cell will also work.
In the second DT generated below, change the selectInput in col from A to something else, say, B. Check that this change is detected in the TableOutput below.
De-select the selected cell
Re-select the same cell.
Now, you can change the selectInput again but no changes will be detected.
Also, I am not sure how to use session$sendCustomMessage("unbind-DT", "oTable"), I tried changing oTable to nTable but that didn't work.
library(shiny)
library(DT)
runApp(list(
ui = basicPage(
tags$script(
HTML(
"Shiny.addCustomMessageHandler('unbind-DT', function(id) {
Shiny.unbindAll($('#'+id).find('table').DataTable().table().node());
})"
)
),
h2('The data'),
DT::dataTableOutput("oTable"),
DT::dataTableOutput("nTable"),
h2("Selected"),
tableOutput("checked")
),
server = function(input, output, session) {
# helper function for making checkbox
shinyInput = function(FUN, len, id, ...) {
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i),label=NULL, ...))
}
inputs
}
mydata=reactive({
session$sendCustomMessage("unbind-DT", "oTable")
input$oTable_cells_selected
})
output$nTable=renderDataTable({
req(mydata())
dd=as.data.frame(mydata())
dd$col=shinyInput(selectInput,nrow(dd),"selecter_",choices=LETTERS[1:3])
dd
},selection='none',server=FALSE,escape=FALSE,rownames=FALSE,
options=list(
preDrawCallback = JS(
'function() {
Shiny.unbindAll(this.api().table().node()); }'
),
drawCallback = JS('function() {
Shiny.bindAll(this.api().table().node()); } ')
))
output$oTable=renderDataTable(DT::datatable(iris,selection=list(mode="multiple",target='cell')))
# helper function for reading select input
shinyValue = function(id, len) {
unlist(lapply(seq_len(len), function(i) {
value = input[[paste0(id, i)]]
if (is.null(value))
NA
else
value
}))
}
# output read selectInput
output$checked <- renderTable({
req(mydata())
data.frame(selected = shinyValue("selecter_", nrow(mydata())))
})
}
))
You have to run Shiny.unbindAll on nTable (the table which contains the inputs). But only after the table has been created a first time.
library(shiny)
library(DT)
runApp(list(
ui = basicPage(
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());
}
})"
))
),
h2('The data'),
DT::dataTableOutput("oTable"),
DT::dataTableOutput("nTable"),
h2("Selected"),
tableOutput("checked")
),
server = function(input, output, session) {
# helper function for making checkbox
shinyInput = function(FUN, len, id, ...) {
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i),label=NULL, ...))
}
inputs
}
observeEvent(input$oTable_cells_selected, {
session$sendCustomMessage("unbindDT", "nTable")
})
mydata = eventReactive(input$oTable_cells_selected, {
if(length(input$oTable_cells_selected)){
input$oTable_cells_selected
}
})
output$nTable=DT::renderDataTable({
req(mydata())
dd=as.data.frame(mydata())
dd$col=shinyInput(selectInput,nrow(dd),"selecter_",choices=LETTERS[1:3])
datatable(dd, selection='none', escape=FALSE,rownames=FALSE,
options=list(
preDrawCallback = JS(
'function() {
Shiny.unbindAll(this.api().table().node()); }'
),
drawCallback = JS('function() {
Shiny.bindAll(this.api().table().node()); } ')
))
},server=FALSE)
output$oTable=DT::renderDataTable(
DT::datatable(iris,selection=list(mode="multiple",target='cell'),
options=list(pageLength = 5)))
# helper function for reading select input
shinyValue = function(id, len) {
unlist(lapply(seq_len(len), function(i) {
value = input[[paste0(id, i)]]
if (is.null(value))
NA
else
value
}))
}
# output read selectInput
output$checked <- renderTable({
req(mydata())
data.frame(selected = shinyValue("selecter_", nrow(mydata())))
})
}
))
Related
I'm trying to use the shinyjs package to clear and disable an input field that has a default value in my shiny app. The clear/disable button seems to work. However, when I click submit, the default value is still being submitted (see picture below). How can I make it submit a NULL or an empty string?
library(shinyjs)
library(shiny)
# this is supposed to change the input value to null
jsCode <- 'shinyjs.clear_input = function(params){
var defaultParams = {
input_id : null
};
params = shinyjs.getParams(params, defaultParams);
var el = $("#" + params.input_id);
el.val(null);}'
shinyApp(
ui = fluidPage(
useShinyjs(),
extendShinyjs(text = jsCode, functions = c("clear_input")),
textInput("input", label = "input", value = "default text"),
actionButton("clear", label = "clear/disable"),
actionButton("submit", "submit"),
tags$div(id="result")
),
server = function(input, output) {
observeEvent(input$clear, {
js$clear_input("input")
disable("input")
})
observeEvent(input$submit, {
insertUI("#result", ui=renderText(input$input))
})
}
)
Personally, I am not very comfortable with javascript so I try to avoid as much as possible and do it in R. You can use updateTextInput to update the values in textInput.
library(shiny)
library(shinyjs)
shinyApp(
ui = fluidPage(
useShinyjs(),
textInput("input", label = "input", value = "default text"),
actionButton("clear", label = "clear/disable"),
actionButton("submit", "submit"),
tags$div(id="result")
),
server = function(input, output, session) {
observeEvent(input$clear, {
updateTextInput(session, "input", value = "")
disable("input")
})
observeEvent(input$submit, {
insertUI("#result", ui=renderText(input$input))
})
}
)
Sticking to the Javascript and following Ronak's idea with using updateTextInput()
library(shinyjs)
library(shiny)
# this is supposed to change the input value to null
jsCode <- 'shinyjs.clear_input = function(params){
var defaultParams = {
input_id : null
}
;
params = shinyjs.getParams(params, defaultParams);
var el = $("#" + params.input_id);
el.val(null);}'
shinyApp(
ui = fluidPage(
useShinyjs(),
extendShinyjs(text = jsCode, functions = c("clear_input")),
textInput("input", label = "input", value = "default text"),
actionButton("clear", label = "clear/disable"),
actionButton("submit", "submit"),
tags$div(id="result")
),
server = function(input, output) {
observeEvent(input$clear, {
updateTextInput(inputId="input", value=js$clear_input("input"))
disable("input")
})
observeEvent(input$submit, {
insertUI("#result", ui=renderText(input$input))
})
}
)
Take this example from the reactable documentation (interactive Shiny example provided at link):
data <- cbind(
MASS::Cars93[1:5, c("Manufacturer", "Model", "Type", "Price")],
details = NA
)
reactable(
data,
columns = list(
# Render a "show details" button in the last column of the table.
# This button won't do anything by itself, but will trigger the custom
# click action on the column.
details = colDef(
name = "",
sortable = FALSE,
cell = function() htmltools::tags$button("Show details")
)
),
onClick = JS("function(rowInfo, colInfo) {
// Only handle click events on the 'details' column
if (colInfo.id !== 'details') {
return
}
// Display an alert dialog with details for the row
window.alert('Details for row ' + rowInfo.index + ':\\n' + JSON.stringify(rowInfo.row, null, 2))
// Send the click event to Shiny, which will be available in input$show_details
// Note that the row index starts at 0 in JavaScript, so we add 1
if (window.Shiny) {
Shiny.setInputValue('show_details', { index: rowInfo.index + 1 }, { priority: 'event' })
}
}")
)
I want to include 2 buttons per details column cell, which I can do by changing the cell definition to:
cell = function() {
a <- htmltools::tags$button("Approve")
b <- htmltools::tags$button("Decline")
return(list(a,b))
}
But then how to differentiate between the Approve/Decline button within the JS() onClick() function? Is there another parameter I can pass that will give me this ability? I console.log'd both rowInfo and colInfo and could not find anything that seemed helpful to identify the two buttons. I'd like to have it so that I can return both:
Shiny.setInputValue('approve_button_click', ...)
and
Shiny.setInputValue('decline_button_click',...)
from the JS side so I can handle them separately in R. Any help is appreciated!
If you want to get just the row index you can do:
library(htmltools)
details = colDef(
name = "",
sortable = FALSE,
cell = function(value, rowIndex, colName){
as.character(tags$div(
tags$button("Approve", onclick=sprintf('alert("approve - %d")', rowIndex)),
tags$button("Decline", onclick=sprintf('alert("decline - %d")', rowIndex))
))
},
html = TRUE
)
In Shiny:
reactable(
data,
columns = list(
details = colDef(
name = "",
sortable = FALSE,
cell = function(value, rowIndex, colName){
as.character(tags$div(
tags$button(
"Approve",
onclick =
sprintf(
'Shiny.setInputValue("approve", %d, {priority: "event"})',
rowIndex
)
),
tags$button(
"Decline",
onclick =
sprintf(
'Shiny.setInputValue("decline", %d, {priority: "event"})',
rowIndex
)
)
))
},
html = TRUE
)
)
)
I have a DT table in shiny app that have background color set to match certain values. I'm also using the selected rows in table to control other part of the app. Now my problem is to make it obvious which rows are selected.
Usually selected rows in table will have background color changed, but I don't have this option since I set the background color already and don't want to change it. Changing foreground color (font color) for selected rows is not optimal as this is not obvious and intuitive.
Right now I'm making selected rows have different opacity with unselected rows, which works to some degree but still not optimal.
One approach can be add some checked icon to the selected rows. Note I don't want real checkbox input because that will lead user to click the checkbox, while I think it's easier just to click row to select.
There are some examples to show html content in DT table, however that will mean dynamically change table content by row selection, which is not acceptable to my app, since each table content change will trigger table refresh, which reset the row selection and come into a loop.
I think it should be possible to use js to change selected rows css class and thus add a checked icon to them. I saw this question which is kind of similar, however the example is hard to understand to me.
Update: This answer by #Stéphane Laurent solved my problem exactly. I searched SO extensively before but didn't find this.
Update 2: My use cases is more complex, and I'm having problems adapting this approach. I need 2 control tables, and I'm switching them based on a radio button control. With dynamic rendering of the table, the excluded status get reset in every switch. Previously I used DT row selection which don't have this problem.
See example below, exclude some rows in table 1, switch to table 2, then switch back, the exclude status is restored.
library(shiny)
library(DT)
# DT checked js ----
rowNames <- FALSE # whether to show row names in the table
colIndex <- as.integer(rowNames)
# making variants since we have two table. not worth a function since only two instances. main changes are function name and shiny input id excludedRows
callback1 <- c(
sprintf("table.on('click', 'td:nth-child(%d)', function(){", colIndex+1),
" var td = this;",
" var cell = table.cell(td);",
" if(cell.data() === 'ok'){",
" cell.data('remove');",
" } else {",
" cell.data('ok');",
" }",
" var $row = $(td).closest('tr');",
" $row.toggleClass('excluded');",
" var excludedRows = [];",
" table.$('tr').each(function(i, row){",
" if($(this).hasClass('excluded')){",
" excludedRows.push(parseInt($(row).attr('id').split('_')[1]));",
" }",
" });",
" Shiny.setInputValue('excludedRows1', excludedRows);",
"})"
)
callback2 <- c(
sprintf("table.on('click', 'td:nth-child(%d)', function(){", colIndex+1),
" var td = this;",
" var cell = table.cell(td);",
" if(cell.data() === 'ok'){",
" cell.data('remove');",
" } else {",
" cell.data('ok');",
" }",
" var $row = $(td).closest('tr');",
" $row.toggleClass('excluded');",
" var excludedRows = [];",
" table.$('tr').each(function(i, row){",
" if($(this).hasClass('excluded')){",
" excludedRows.push(parseInt($(row).attr('id').split('_')[1]));",
" }",
" });",
" Shiny.setInputValue('excludedRows2', excludedRows);",
"})"
)
# for select all, not using it now
# restore <- c(
# "function(e, table, node, config) {",
# " table.$('tr').removeClass('excluded').each(function(){",
# sprintf(" var td = $(this).find('td').eq(%d)[0];", colIndex),
# " var cell = table.cell(td);",
# " cell.data('ok');",
# " });",
# " Shiny.setInputValue('excludedRows', null);",
# "}"
# )
render <- c(
'function(data, type, row, meta){',
' if(type === "display"){',
' var color = data === "ok" ? "#027eac" : "gray";',
' return "<span style=\\\"color:" + color +',
' "; font-size:18px\\\"><i class=\\\"glyphicon glyphicon-" +',
' data + "\\\"></i></span>";',
' } else {',
' return data;',
' }',
'}'
)
# test app ----
ui <- fluidPage(
tags$head(
tags$style(HTML(
".excluded { color: gray; font-style: italic; }"
))
),
fluidRow(
column(
6,
tags$label("Excluded rows Table 1"),
verbatimTextOutput("excludedRows1"),
tags$label("Excluded rows Table 2"),
verbatimTextOutput("excludedRows2")
),
column(
6,
tags$label("Included rows"),
verbatimTextOutput("includedRows1"),
verbatimTextOutput("includedRows2")
)
),
br(),
radioButtons("select_table", label = "Select table", choices = c("1", "2"), inline = TRUE),
uiOutput("control_table_ui")
# tabBox(tabPanel("1", DTOutput("mytable1")),
# tabPanel("2", DTOutput("mytable2")))
)
server <- function(input, output,session) {
output$control_table_ui <- renderUI({
if (input$select_table == "1") {
column(12, offset = 0, DTOutput("mytable1"))
} else {
column(12, offset = 0, DTOutput("mytable2"))
}
})
dt <- cbind(On = "ok", mtcars[1:6,], id = paste0("row_",1:6))
row_colors <- rep(c("red", "blue", "green"), 2)
names(row_colors) <- dt$id
output[["mytable1"]] <- renderDT({
datatable(dt, caption = "table 1",
rownames = rowNames, extensions = c("Select"),
selection = "none", callback = JS(callback1),
options = list(
# pageLength = 3,
sort = FALSE,
rowId = JS(sprintf("function(data){return data[%d];}",
ncol(dt)-1+colIndex)),
columnDefs = list(
list(visible = FALSE, targets = ncol(dt)-1+colIndex),
list(className = "dt-center", targets = "_all"),
list(className = "notselectable", targets = colIndex),
list(targets = colIndex, render = JS(render))
),
dom = "t",
# buttons = list(list(
# extend = "collection",
# text = 'Select All',
# action = JS(restore)
# )
# ),
select = list(style = "single", selector = "td:not(.notselectable)")
# select = list(style = 'os', # set 'os' select style so that ctrl/shift + click in enabled
# items = 'row') # items can be cell, row or column
)
) %>%
formatStyle("id", target = "row",
backgroundColor = styleEqual(dt$id, row_colors))
}, server = FALSE)
output[["mytable2"]] <- renderDT({
datatable(dt, caption = "table 2",
rownames = rowNames, extensions = c("Select"),
selection = "none", callback = JS(callback2),
options = list(
# pageLength = 3,
rowId = JS(sprintf("function(data){return data[%d];}",
ncol(dt)-1+colIndex)),
columnDefs = list(
list(visible = FALSE, targets = ncol(dt)-1+colIndex),
list(className = "dt-center", targets = "_all"),
list(className = "notselectable", targets = colIndex),
list(targets = colIndex, render = JS(render))
),
dom = "t",
# buttons = list(list(
# extend = "collection",
# text = 'Select All',
# action = JS(restore)
# )
# ),
select = list(style = "single", selector = "td:not(.notselectable)")
)
) %>%
formatStyle("id", target = "row",
backgroundColor = styleEqual(dt$id, row_colors))
}, server = FALSE)
output$excludedRows1 <- renderPrint({
input[["excludedRows1"]]
})
output$excludedRows2 <- renderPrint({
input[["excludedRows2"]]
})
output$includedRows1 <- renderPrint({
setdiff(1:nrow(dt), input[["excludedRows1"]])
})
}
shinyApp(ui, server)
Update 3: Per #Stéphane Laurent 's suggestion, using conditionalPanel solved the problem. Although it's a little bit slower than renderUI, but it's working.
Thanks to #StéphaneLaurent 's answer which is a great js based solution and solved my 95% needs. However I need a button to clear all selection and cannot write that one because of my limited js skills. I also forgot the important server=FALSE parameter so met problem of sorting lost selection. Thus I switched back to my original row selection mechanism.
I used to try to modify the table by row selection, but that will trigger reactive event loop. Later I realized I only need to change the view, not the underlying data, and changing view is possible by purely css rules.
Checking the great example here, the more icons example can show different icon depend on checkbox selection. By inspecting the css rules, I found both icons are there all the time, just the css rule is different depend on selection status.
Thus I came up with this solution, which used the builtin row selection in DT and some css rules, this way you still have all the feature of row selection control in DT without needs of js code, and everything is implemented by css.
library(shiny)
library(DT)
library(data.table)
ui <- fluidPage(
tags$head(
tags$style(HTML("
.selected .table-icon-yes {
opacity: 1;
display: inline-block;
color: #3c763d;
}
.table-icon-yes {
opacity: 0;
display: none;
}
.selected .table-icon-no {
opacity: 0;
display: none;
}
.table-icon-no {
opacity: 1;
display: inline-block;
color: #999;
}
"))
),
DTOutput("table")
)
icon_col <- tagList(span(class = "table-icon-yes", icon("ok", lib = "glyphicon")),
span(class = "table-icon-no", icon("remove", lib = "glyphicon")))
server <- function(input, output, session) {
output$table <- renderDT({
dt <- data.table(iris)
dt[, Selected := as.character(icon_col)]
setcolorder(dt, c(ncol(dt), 1:(ncol(dt) - 1)))
datatable(dt, escape = FALSE)
})
}
shinyApp(ui = ui, server = server)
The app below contains a selectInput input$set1 with two options (download and upload) and a radio button group input$set2 that is rendered using renderUI(). I am using a custom message handler that disables a radio button in the radio button group depending on the value of the selectInput (if input$set1 == 'download' then disable the upload radio button and enable it otherwise).
Here is the app:
library(shiny)
library(shinyWidgets)
library(shinydashboard)
toggleRadioOpt <- function(session, inputId, choice, enable = TRUE, selected) {
session$sendCustomMessage(
type = 'toggleRadioOpt',
message = list(id = inputId, choice = choice, enable = enable, selected = selected)
)
}
modUI <- function(id) {
ns <- NS(id)
tagList(
tags$head(
tags$script("
Shiny.addCustomMessageHandler('toggleRadioOpt',
function(data) {
$('#' + data.id + ' input[value = \"' + data.choice + '\"]').attr('disabled', !data.enable).prop('checked', false);
if(data.selected !== null) {
$('#' + data.id + ' input[value = \"' + data.selected + '\"]').prop('checked', true);
}
}
);
")
),
prettyRadioButtons(ns('set1'), label = 'Select', choices = c('download', 'upload', 'abb')),
# selectInput(ns('set1'), label = 'Select', choices = c('download', 'upload', 'sql')),
uiOutput(ns('taskUI'))
)
}
modServer <- shinyServer(function(input, output, session) {
ns = session$ns
output$taskUI <- renderUI({
switch(input$set1,
'download' = selectInput(ns('data'), '', state.area),
'upload' = selectInput(ns('data'), '', state.center),
'abb' = tagList(
selectInput(ns('data'), '', state.abb),
actionButton(ns('upload'), 'Upload')
)
)
prettyRadioButtons(ns('set2'), label = '', choices = c('split', 'upload'))
})
observe({
if(!is.null(input$set2)) {
if(input$set1 %in% c('download', 'abb')) {
toggleRadioOpt(session = session, inputId = ns('set2'), choice = 'upload', enable = F, selected = 'split')
} else {
toggleRadioOpt(session = session, inputId = ns('set2'), choice = 'upload', enable = T, selected = 'split')
}
}
})
})
# UI ----------------------------------------------------------------------
ui = fluidPage(modUI('first'))
# SERVER ------------------------------------------------------------------
server <- shinyServer(function(input, output, session) {
callModule(modServer, 'first')
})
shinyApp(ui, server)
The handler works as expected if the radio button group is created in the UI but fails if the buttons are created using renderUI(). Specifically, it fails on startup but then works if input$set1 is changed subsequently. I am new to using custom message handlers so I'm not sure what's going on here or how to fix it. I thought it may have something to do with the jQuery being triggered before the UI has loaded but I can't be sure.
I thought it may have something to do with the jQuery being triggered
before the UI has loaded but I can't be sure.
I think so. Before the UI has loaded, input$set2 is NULL. You can do:
observe({
if(!is.null(input$set2)){
if(input$set1 == 'download') {
toggleRadioOpt(session = session, inputId = ns('set2'), choice = 'upload',
enable = F, selected = 'split')
} else {
toggleRadioOpt(session = session, inputId = ns('set2'), choice = 'upload',
enable = T, selected = 'split')
}
}
})
I am working on a shiny app. The server.R contains codes like......
dFt1 <- reactiveValues()
dFt1$dat <- data.frame(loadTransactionData())
...
output$t_tab_1 <- DT::renderDataTable({
DT::datatable(
dFt1$dat
,selection = list(mode = "single")
,options = list(
rownames = TRUE
,pageLength = 10
,order = list(list(2,"desc"),list(1,"asc"))
)
)
})
...
observe({
if (is.null(input$delete) || input$delete == 0){return()}
session$sendCustomMessage(
type = 'jsCode'
,list(value = 'confirm("Are You Sure?");')
)
})
observeEvent(input$deleteConfirmChoice, {
if (input$deleteConfirmChoice == "TRUE") {
x <- input$t_tab_1_rows_selected
deleteTransaction(x)
isolate(dFt1$dat <- dFt1$dat[row.names(dFt1$dat) != x, ])
}
})
deleteTransaction <- function(x) {
qy <- "DELETE FROM Transactions where timestamp = '<t>'"
qy <- gsub("<t>",x,qy)
db <- dbConnect(SQLite(), dbname=systemDatabase)
dbGetQuery(db,qy)
dbDisconnect(db)
}
And of course there is the delete button in the ui.R and a called to javascript confirm box.
The app runs good. I can select a record and delete it. Then I can select another record. But I cannot delete it. The javascript confirm box runs, but clicking Yes does not delete the record. I wonder why it is okay for 1 time but not the next time.
Any help?
Ok! Finally come to something that is working ...
observeEvent(input$deleteConfirmChoice, {
if (input$deleteConfirmChoice == "TRUE") {
x <- input$t_tab_1_rows_selected
deleteTransaction(x)
isolate(dFt1$dat <- dFt1$dat[row.names(dFt1$dat) != x, ])
shinyjs::disable("delete")
shinyjs::disable("edit")
session$sendCustomMessage(
type = 'jsCode'
,list(value = '1 != 1;')
)
}
})
I added another session$sendCustomMessage call that evaluate to be FALSE.
Wonder if there is any better solution?
Here is another approach...
I changed the javascript code passed to session$sendCustomMessage. Clicking the No button returns 0. Clicking the Yes button returns a random number. This I hope will guarantee a different value in two consecutive clicks of the Yes button.
observe({
if (is.null(input$delete) || input$delete == 0){return()}
session$sendCustomMessage(
type = 'jsCode'
,list(value =
'
(function() {
if (confirm("Are you sure?")) {
return Math.random()*3 + 1;
} else {
return 0;
}
})()
'
)
)
})
observeEvent(input$deleteConfirmChoice, {
if (input$deleteConfirmChoice == "TRUE") {
x <- input$t_tab_1_rows_selected
deleteTransaction(x)
isolate(dFt1$dat <- dFt1$dat[row.names(dFt1$dat) != x, ])
}
})
Any other cleaner solution?