We Keep Coding

How to freeze left column of matrix viewed in R shiny modal dialog?

The below reproducible code renders a user input matrix grid inside a modal dialog box (click on the single action button at the top when invoking the App), with the user input matrix: (a) automatically expanding to the right as the user inputs data into the columns, (b) automatically generating sequentially numbered column headers, and (c) rendered inside a scrollable well panel so that it expands without "scrunching" as it grows.
However, I would like to "freeze" the left-most column of the matrix input grid (the row headers), so the user doesn't lose the meanings of individual rows as the grid grows. The images at the bottom better illustrate. How can this be done?
I assume this requires some gyrations with shinyjs, an area I am very weak in. This is a follow-up evolution of earlier post In R shiny, how to incorporate scrolling into modal dialog box?
Reproducible code:
library(shiny)
library(shinyMatrix)
library(shinyjs)
library(shinyWidgets)
library(magrittr)
library(DT)
mat1DefaultRownames <- c('Item A','Item B','Item C','Item D')
mat1Default <- data.frame('Series 1'=c(1,24,0,100), row.names = mat1DefaultRownames) %>% as.matrix()
mat1Input <- function(inputId, mat1Default) {
matrixInput(
inputId = inputId,
label = "Input terms:",
value = mat1Default,
rows = list(extend = FALSE, names = TRUE),
cols = list(extend = TRUE, names = TRUE, editableNames = FALSE, delete = TRUE),
class = "numeric"
)
}
ui <-
fluidPage(
shinyjs::useShinyjs(),
div(style = "margin-top: 10px"),
actionButton('modInputs','Input terms', style = 'width:25%'),
DTOutput("table1")
)
server <- function(input,output,session)({
rv1 <- reactiveValues(
mat1 = mat1Input("mat1",mat1Default),
input = mat1Default,
colHeader = colnames(input)
)
mat1Inputs <- reactive({
if (isTruthy(input$modInputs)) {
req(input$mat1)
df <- input$mat1
rv1$mat1 <- mat1Input("mat1", df)
colnames(df) <- paste("Series",rep(1:ncol(df),each=1,length.out=ncol(df)))
rownames(df) <- mat1DefaultRownames
rv1$input <- df
updateMatrixInput(session, inputId = "mat1", value = rv1$input)
} else {
df <- mat1Default
colnames(df) <- paste("Series", 1:ncol(df))
}
df[3:4, ] <- sprintf('%.2f%%', df[3:4, ])
df
})
output$table1 <-
renderDT(server = TRUE, {
datatable(
data = mat1Inputs(),
options = list(
scrollX = T,
dom = 'ft',
autoWidth = FALSE,
info = FALSE,
searching = FALSE,
columnDefs =
list(
list(className = 'dt-left', targets = 0),
list(className = 'dt-right', targets = seq_len(ncol(mat1Inputs())))
)
),
class = "display nowrap"
)
})
observeEvent(input$modInputs, {
showModal(
modalDialog(
wellPanel(div(style = "overflow-x: auto;", rv1$mat1)),
footer = tagList(actionButton("resetInputs", "Reset"),modalButton("Close"))
)
)
})
observeEvent(c(input$modInputs, input$mat1), {
runjs(
paste0(
'$("#mat1").css("width","calc(100% + ', (dim(input$mat1)[2]-1 + dim(input$mat1)[2]%%2)*115, 'px")'
) # close paste0
) # close runjs
})
observeEvent(input$resetInputs, {updateMatrixInput(session,'mat1', mat1Default)})
})
shinyApp(ui, server)

How to change names inside filter for booleans in datatable in shiny?

I have a datatable in Shiny where I use the filter option. When I want to filter a boolean column, I can choose true and false. I would like to rename these values. So instead of true and false, it should show yes and no.
The displayed column entries are not TRUE or FALSE but checkboxes. This is important, that's why I add it to the code example.
I had the idea to convert the booleans to factors. Then the filter shows yes and no. However, in this case all checkboxes are checked, so this doesn't work. I commented out the line that does the converting in the code below. If there is a solution without this converting step it would be nice.
As I didn't find any option to change the values, I guess, this can only be accomplished with JavaScript code. Unfortunately, I am not really familiar with JavaScript. I hopse someone call help me here.
library(shiny)
library(DT)
library(dplyr)
library(forcats)
set.seed(43)
data <- data.frame(A = rnorm(10),
B = letters[1:10],
C = sample(c(TRUE, FALSE), 10, TRUE))
ui <- fluidPage(
DTOutput("table_id")
)
server <- function(input, output, session) {
output$table_id <- renderDT(
data %>%
# mutate(C = as_factor(if_else(C == TRUE, "yes", "no"))) %>%
datatable(filter = "top",
options = list(
columnDefs = list(
list(
targets = c(3),
render = JS(
"function(data, type, row, meta) {",
" if(type === 'display'){",
" return data ? '<input type=\"checkbox\" disabled checked/>' : '<input type=\"checkbox\" disabled/>';",
" }",
" return data;",
"}"
)
))
)
)
)
}
shinyApp(ui, server)

Your factor C in your data.frame will pass values of either "yes" or "no"; however, your JS function is checking data to see if it is TRUE or FALSE. If you compare data with "yes", then the "yes" will be considered TRUE and "no" will be considered FALSE. Let me know if this produces the desired behavior.
library(shiny)
library(DT)
set.seed(43)
data <- data.frame(A = rnorm(10),
B = letters[1:10],
C = sample(c(TRUE, FALSE), 10, TRUE))
ui <- fluidPage(
DTOutput("table_id")
)
server <- function(input, output, session) {
output$table_id <- renderDT(
data %>%
mutate(C = as_factor(if_else(C == TRUE, "yes", "no"))) %>%
datatable(filter = "top",
options = list(
columnDefs = list(
list(
targets = c(3),
render = JS(
"function(data, type, row, meta) {",
" if(type === 'display'){",
" return data == \"yes\" ? '<input type=\"checkbox\" disabled checked/>' : '<input type=\"checkbox\" disabled/>';",
" }",
" return data;",
"}"
)
))
)
)
)
}
shinyApp(ui, server)

How to differentiate between buttons in R/Shiny reactable javascript callback?

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
)
)
)

R Shiny - Using a custom message handler to disable a single radio button in a radio button group

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')
}
}
})

embed select input in DT generated from another DT with cell selection

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())))
})
}
))