I need a shiny DT datatable with radio buttons embedded in a column. This app shows a solution for horizontal buttons so I started adapting it, for the vertical case. The matrix was easy to modify (see code below), however, I got stuck in the callback part due to my lack of knowledge of JavaScript. Any ideas?
UPDATE: Unless radio buttons are a must, it is easier to use the row selection functionality in DT, and just set selection="single", so that only one row can be selected.
library(shiny)
library(DT)
m = matrix(
as.character(1:12), nrow = 12, ncol = 5, byrow = FALSE,
dimnames = list(month.abb, LETTERS[1:5])
)
for (i in seq_len(ncol(m))) {
#for (i in 1) {
m[,i ] = sprintf(
'<input type="radio" name="%s" value="%s"/>',
LETTERS[i], m[,i]
)
}
shinyApp(
ui = fluidPage(
title = 'Radio buttons in a table',
DT::dataTableOutput('foo'),
verbatimTextOutput('sel')
),
server = function(input, output, session) {
output$foo = DT::renderDataTable(
m, escape = FALSE, selection = 'none', server = FALSE,
options = list(dom = 't', paging = FALSE, ordering = FALSE),
callback = JS("table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-radiogroup');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());")
)
output$sel = renderPrint({
input[["A"]]
})
}
)
library(shiny)
library(DT)
m = matrix(
as.character(1:12), nrow = 12, ncol = 5, byrow = FALSE,
dimnames = list(month.abb, LETTERS[1:5])
)
for (i in seq_len(ncol(m))) {
m[, i] = sprintf(
'<input type="radio" name="%s" value="%s"/>',
LETTERS[i], m[,i]
)
}
callback <- c(
"var LETTERS = ['A','B','C','D','E'];",
"for(var i=0; i < LETTERS.length; ++i){",
" var L = LETTERS[i];",
" $('input[name=' + L + ']').on('click', function(){",
" var name = $(this).attr('name');",
" var value = $('input[name=' + name + ']:checked').val();",
" Shiny.setInputValue(name, value);",
" });",
"}"
)
shinyApp(
ui = fluidPage(
title = 'Radio buttons in a table',
DT::dataTableOutput('foo'),
verbatimTextOutput('sel')
),
server = function(input, output, session) {
output$foo = DT::renderDataTable(
m, escape = FALSE, selection = 'none', server = FALSE,
options = list(dom = 't', paging = FALSE, ordering = FALSE),
callback = JS(callback)
)
output$sel = renderPrint({
input[["A"]]
})
}
)
Related
I need to insert radio buttons in a shiny DT datable application. I took inspiration from here (inst/examples/DT-radio/app.R) to do it.
However, for my case, I have several tables (not just one) and I can't manage them.
What I want is to get all the radio buttons selected in table 1 and all the radio buttons selected in table 2.
When I select a cell in the first row of table 1, and then a cell in the first row of table 2, the cell in the first table is no longer selected. Moreover, I get the selected cells for table 1 but not for table 2.
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
title = 'Radio buttons in a table',
DT::dataTableOutput('un'),
tags$br(),
tags$br(),
tags$br(),
DT::dataTableOutput('deux'),
tags$br(),
tags$br(),
tags$br(),
verbatimTextOutput('sel')
),
server = function(input, output, session) {
# first table construction ------------------
m1 = matrix(
as.character(1:3), nrow = 3, ncol = 3, byrow = TRUE,
dimnames = list(month.abb[1:3], LETTERS[1:3])
)
for (i in seq_len(nrow(m1))) {
m1[i, ] = sprintf('<input type="radio" name="%s" value="%s"/>', month.abb[i], m1[i, ])
}
# -------------------------------------------
# second table construction ------------------
m2 = matrix(
as.character(1:5), nrow = 5, ncol = 3, byrow = TRUE,
dimnames = list(c("julie", "sophie", "patricia", "carole", "therese"), LETTERS[1:3])
)
for (i in seq_len(nrow(m2))) {
m2[i, ] = sprintf('<input type="radio" name="%s" value="%s"/>', month.abb[i], m2[i, ])
}
# -------------------------------------------
# overall row names for 2 table
overall = c(month.abb[1:3], c("julie", "sophie", "patricia", "carole", "therese"))
# First table-------------------------------
output$un = DT::renderDataTable(
m1, escape = FALSE, selection = 'none', server = FALSE,
options = list(dom = 't', paging = FALSE, ordering = FALSE),
callback = JS("table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-radiogroup');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());")
)
# -------------------------------------------
# Second table --------------------------------
output$deux = DT::renderDataTable(
m2, escape = FALSE, selection = 'none', server = FALSE,
options = list(dom = 't', paging = FALSE, ordering = FALSE),
callback = JS("table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-radiogroup');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());")
)
# -------------------------------------------
output$sel = renderPrint({
str(sapply(overall, function(i) input[[i]]))
})
})
Thanks
You may have a typo. Try this
# second table construction ------------------
m2 = matrix(
as.character(1:5), nrow = 5, ncol = 3, byrow = TRUE,
dimnames = list(mynames, LETTERS[1:3])
)
mynames <- c("julie", "sophie", "patricia", "carole", "therese")
for (i in seq_len(nrow(m2))) {
m2[i, ] = sprintf('<input type="radio" name="%s" value="%s"/>', mynames[i], m2[i, ])
}
I am quite new to JavaScript callbacks in Shiny apps.
Could someone explain to me why the following code snippet won't work if I switch server to TRUE ?
The "sel" output no longer render the values of the radio buttons correctly. In other words, the renderPrint still displays NULL for the 12 months even when I click on the buttons.
I found this example here : https://yihui.shinyapps.io/DT-radio/
Thank you in advance
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
title = 'Radio buttons in a table',
DT::dataTableOutput('foo'),
verbatimTextOutput('sel')
),
server = function(input, output, session) {
m = matrix(
as.character(1:5), nrow = 12, ncol = 5, byrow = TRUE,
dimnames = list(month.abb, LETTERS[1:5])
)
for (i in seq_len(nrow(m))) {
m[i, ] = sprintf(
'<input type="radio" name="%s" value="%s"/>',
month.abb[i], m[i, ]
)
}
m
output$foo = DT::renderDataTable(
m, escape = FALSE, selection = 'none', server = FALSE,
options = list(dom = 't', paging = FALSE, ordering = FALSE),
callback = JS("table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-radiogroup');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());")
)
output$sel = renderPrint({
str(sapply(month.abb, function(i) input[[i]]))
})
}
)
I would like to collect some data with the ShinyR app and include a texinput option if someone selects other. Is it possible to include a text input in datatable constructed with javascript for a ShinyR app?
Example table:
library(shiny)
library(DT)
answer_options<- c("reading", "swimming",
"cooking", "hiking","binge- watching series",
"other")
question2<- "What hobbies do you have?"
shinyApp(
ui = fluidPage(
h2("Questions"),
p("PLease answer the question below. "),
DT::dataTableOutput('checkbox_matrix'),
tags$script(HTML("Shiny.addCustomMessageHandler('unbind-DT', function(id) {
Shiny.unbindAll($('checkbox_matrix'+id).find('table').DataTable().table().node());
})")
)
),
server = function(input, output, session) {
checkbox_m = matrix(
as.character(answer_options), nrow = length(answer_options), ncol = length(question2), byrow = TRUE,
dimnames = list(answer_options, question2)
)
for (i in seq_len(nrow(checkbox_m))) {
checkbox_m[i, ] = sprintf(
'<input type="checkbox" name="%s" value="%s"/>',
answer_options[i], checkbox_m[i, ]
)
}
checkbox_m
output$checkbox_matrix= DT::renderDataTable(
checkbox_m, escape = FALSE, selection = 'none', server = TRUE,
options = list(dom = 't', paging = FALSE, ordering = FALSE),
callback = JS("table.on('click.dt', 'td', function() {
var row_=table.cell(this).index().row;
var col=table.cell(this).index().column;
var data = [row_, col];
Shiny.onInputChange('rows',data );
});")
)
}
)
What I am trying to accomplish is similar to this thread, but slightly more complicated.
I would like to group the radio buttons into different groups, but in one column so a "subselection" of rows is possible.
Currently only the radio button group with ID "C" works, because the div element is defined for the whole table. I have tried to insert the shiny tags via javascript callback, but I'm only able to insert a radio button for each row or for each column, but not for a subset of multiple rows in one column.
Open to javascript or shiny solutions.
shinyApp(
ui = fluidPage(
title = 'Radio buttons in a table',
tags$div(id="C",class='shiny-input-radiogroup',DT::dataTableOutput('foo')),
verbatimTextOutput("test")
),
server = function(input, output, session) {
m = matrix(
c(round(rnorm(24),1), rep(3,12)), nrow = 12, ncol = 3, byrow = F,
dimnames = list(month.abb, LETTERS[1:3])
)
m[, 2] <- rep(c("A","B","C", "D"), each= 3)
m[, 3] <- paste0('<input type="radio" name="', rep(c("A","B","C", "D"), each= 3),'" value="', month.abb,'"/>')
m[c(1,4,7,10), 3] <- gsub('/>', 'checked="checked"/>', m[c(1,4,7,10), 3], fixed = T)
m
output$foo = DT::renderDataTable(
m, escape = FALSE, selection = 'none', server = FALSE,
options = list(dom = 't', paging = FALSE, ordering = FALSE)
# callback = JS("table.rows().every(function() {
# var $this = $(this.node());
# $this.attr('id', this.data()[0]);
# $this.addClass('shiny-input-radiogroup');
# });
# Shiny.unbindAll(table.table().node());
# Shiny.bindAll(table.table().node());")
)
output$test <- renderPrint(str(input$C))
}
)
UPDATE:
The rough structure of my final solution with reactive button selection. The inputs and visuals stay preserved with re-rendering the table (just the first time the input renders as NULL which is no particular problem for me).
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
title = "Radio buttons in a table",
sliderInput("slider_num_rows", "Num Rows", min = 2, max = 12, value = 5),
tags$div(id = 'placeholder'),
verbatimTextOutput("test")
),
server = function(input, output, session) {
rea <- reactive({
m = matrix(
c(round(rnorm(24),1), rep(3,12)), nrow = 12, ncol = 3, byrow = F,
dimnames = list(month.abb, LETTERS[1:3])
)
m[, 2] <- rep(c("A","B","C", "D"), each= 3)
m[, 3] <- paste0('<input type="radio" name="', rep(c("A","B","C", "D"), each= 3),'" value="', month.abb,'"/>')
save_sel <- c()
mon_tes <- c("Jan", "Apr", "Jul", "Oct")
ab <- c("A", "B", "C", "D")
for (i in 1:4){
if (is.null(input[[ab[i]]])){
save_sel[i] <- mon_tes[i]
} else {
save_sel[i] <- input[[ab[i]]]
}
}
sel <- rownames(m) %in% save_sel
m[sel, 3] <- gsub('/>', 'checked="checked"/>', m[sel, 3], fixed = T)
m <- m[1:input$slider_num_rows,]
m
})
output$foo = DT::renderDataTable(
rea(), escape = FALSE, selection = 'none', server = FALSE,
options = list(dom = 't', paging = FALSE, ordering = FALSE,
columnDefs = list(list(className = 'no_select', targets = 3)))
)
observe({
l <- unique(m[, 2])
for(i in 1:length(l)) {
if (i == 1) {
radio_grp <- div(id = l[i], class = "shiny-input-radiogroup", DT::dataTableOutput("foo"))
} else {
radio_grp <- div(id = l[i], class = "shiny-input-radiogroup", radio_grp)
}
}
insertUI(selector = '#placeholder',
ui = radio_grp)
})
output$test <- renderPrint( {
str(input$A)
str(input$B)
str(input$C)
str(input$D)
})
}
)
You can nest the div elements into each other like this:
ui = fluidPage(
title = "Radio buttons in a table",
div(id = "A", class = "shiny-input-radiogroup",
div(id = "B", class = "shiny-input-radiogroup",
div(id = "C", class = "shiny-input-radiogroup",
div(id = "D", class = "shiny-input-radiogroup", DT::dataTableOutput("foo"))
)
)
),
I also modified renderText in order to print all the values.
output$test <- renderPrint( {
str(input$A)
str(input$B)
str(input$C)
str(input$D)
})
Here is the result after interacting with the dataTableOutput (selected the Feb radio button):
Please note that the elements will still have NULL value until interaction. You can get around this problem though, with an if statement, using the default values of radio buttons when the input elements are NULL.
Edit: You can create the divs with a loop like this:
l <- unique(m[, 2])
for(i in 1:length(l)) {
if (i == 1) {
radio_grp <- div(id = l[i], class = "shiny-input-radiogroup", DT::dataTableOutput("foo"))
} else {
radio_grp <- div(id = l[i], class = "shiny-input-radiogroup", radio_grp)
}
}
I have renderDataTable with select Inputs and buttons inside. I want to update selectInput inside datatable after click on 'Save' button in appropriate row. How can I do that? During searching for a solution I found that "if you rerender the table, the inputs won't work unless you add some extra code to unbind". However I am new in shiny and using js options, so I would be grateful for any hints/solutions.
library(shiny)
library(DT)
runApp(list(
ui = basicPage(
h2('The mtcars data'),
DT::dataTableOutput('mytable'),
h2("Selected"),
tableOutput("checked")
),
server = function(input, output) {
# 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), ...))
}
inputs
}
# datatable with checkbox
output$mytable = DT::renderDataTable({
data.frame(mtcars,Rating=shinyInput(selectInput,nrow(mtcars),"selecter_",label=NULL,
choices=1:5, width="60px"),
Save = shinyInput(actionButton, nrow(mtcars),'button_',
label = 'Save',onclick = 'Shiny.onInputChange(\"select_button\", this.id)' ))
}, selection='none',server = FALSE, escape = FALSE, options = list(
paging=TRUE,
preDrawCallback = JS('function() {
Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() {
Shiny.bindAll(this.api().table().node()); } ')
) )
# helper function for reading checkbox
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 checkboxes
output$checked <- renderTable({
data.frame(selected=shinyValue("selecter_",nrow(mtcars)))
})
}
))
Hey so I don't completely understand your question, but hopefully this helps. This app isn't perfect, but should do what you want:
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'),
selectInput("myData", "Choose dataset", c("mtcars", "iris"), "mtcars"),
DT::dataTableOutput('mytable'),
h2("Selected"),
tableOutput("checked")
),
server = function(input, output, session) {
dataset <- reactive({
session$sendCustomMessage("unbind-DT", "mytable")
get(input$myData)
})
# 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), ...))
}
inputs
}
# datatable with checkbox
output$mytable = DT::renderDataTable({
data.frame(
dataset(),
Rating = shinyInput(
selectInput,
nrow(dataset()),
"selecter_",
choices = 1:5,
width = "60px",
label = NULL
),
Save = shinyInput(actionButton, nrow(dataset()), 'button_',
label = 'Save')
)
}, selection = 'none', server = FALSE, escape = FALSE, options = list(
dom = "ti",
paging = TRUE,
preDrawCallback = JS(
'function() {
Shiny.unbindAll(this.api().table().node()); }'
),
drawCallback = JS('function() {
Shiny.bindAll(this.api().table().node()); } ')
))
# helper function for reading checkbox
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 checkboxes
output$checked <- renderTable({
data.frame(selected = shinyValue("selecter_", nrow(mtcars)))
})
lapply(1:150, function(i) {
observeEvent(input[[paste0("button_", i)]], {
updateSelectInput(session,
paste0("selecter_", i),
selected = 5,
label = NULL)
})
})
}
))