R shiny: update select input values in data.table - javascript

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

Related

How to adjust the width of selected columns in datatable (DT)

I am trying to adjust the width of datatable DT in shiny which works for the below simple example -
library(magrittr)
library(shiny)
library(DT)
ui <- fluidPage(
DT::dataTableOutput('dt')
)
server <- function(input, output) {
output$dt <- DT::renderDataTable({
dt1 <- head(mtcars)
DT::datatable(dt1, rownames = FALSE) %>%
DT::formatStyle(columns = c(3,6), width='200px')
})
}
shinyApp(ui, server)
However, my actual datatable is bit complicated and has some javascript functions.
ui <- fluidPage(
DT::dataTableOutput('dt', width = '700px')
)
server <- function(input, output) {
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
}
output$dt<- DT::renderDataTable({
dt1 <- head(mtcars)
df <- cbind(select = shinyInput(shiny::checkboxInput, nrow(dt1), 'check'),dt1)
DT::datatable(df, selection = 'none', escape = FALSE,options = list(
preDrawCallback = htmlwidgets::JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = htmlwidgets::JS('function() { Shiny.bindAll(this.api().table().node()); } '))) %>%
DT::formatStyle(columns = c(3,6), width='200px')
})
}
shinyApp(ui, server)
I copied the shinyInput function from this post.
But now formatStyle does not work on this and no width is changed. I want to give different width to every column manually especially reduce the width of the first column with checkbox (select) which takes up lot of space.
Do you have any idea how can I do this?
You can pass width value to shiny::checkboxInput :
df <- cbind(select = shinyInput(shiny::checkboxInput, nrow(dt1), 'check', width = '10px'),dt1)
Complete app code -
ui <- fluidPage(
DT::dataTableOutput('dt', width = '700px')
)
server <- function(input, output) {
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
}
output$dt<- DT::renderDataTable({
dt1 <- head(mtcars)
df <- cbind(select = shinyInput(shiny::checkboxInput, nrow(dt1), 'check', width = '10px'),dt1)
DT::datatable(df, selection = 'none', escape = FALSE,options = list(
preDrawCallback = htmlwidgets::JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = htmlwidgets::JS('function() { Shiny.bindAll(this.api().table().node()); } '))) %>%
DT::formatStyle(columns = c(3,6), width='200px')
})
}
shinyApp(ui, server)
The following is taken from one of my apps, hope it helps
DT::datatable(
data = data,
options = list(
columnDefs = list(
list(width = "10%", class = "dt-right", targets = 4)
)
)
)
The thing is that you can pass options as a list in columnDefs. That particular option is saying that the fifth column (index starts in 0) has class dt-right (to right-align the content) and its width is 10% of the table. You can pass a vector with more than one element in targets.

R shiny Datatable with Reactive Columns and Popover Tooltips

Does anyone know how to integrate reactive columns with popover tooltips in R shiny?
I have some working code for reactive columns using Datatable based off this post and code:
library(shiny)
library(DT)
server<-function(input, output,session) {
shinyInput <- function(FUN, len, id, ivals, ...) {
inputs <- numeric(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(
FUN(paste0(id, i), label = NULL,
value=ivals[i],...)
)
}
inputs
}
it_df <- reactive({
data.frame(
Parameters = rep("X",7),
Values = shinyInput(numericInput, 7,
'param_values',
numeric(7),
width = '100%'),
stringsAsFactors = FALSE
)
})
output$param_table <- DT::renderDataTable(
datatable(it_df(),escape = FALSE,
options = list(
preDrawCallback = JS("function() { Shiny.unbindAll(this.api().table().node());}"),
drawCallback = JS("function() { Shiny.bindAll(this.api().table().node());}")
)
))
}
ui <- fluidPage( DT::dataTableOutput('param_table'))
shinyApp(ui,server)
I also have some working code for popover tooltips based off this post and code:
library(shiny)
library(DT)
ui<-shinyUI(
mainPanel(
DT::dataTableOutput("tbl")
)
)
server<-shinyServer(function(input, output,session) {
output$tbl = DT::renderDataTable(
datatable(iris[1:5, ], callback = JS("
var tips = ['First row name', 'Second row name', 'Third row name',
'Fourth row name', 'Fifth row name'],
firstColumn = $('#tbl tr td:first-child');
for (var i = 0; i < tips.length; i++) {
$(firstColumn[i]).attr('title', tips[i]);
}")), server = FALSE)
})
shinyApp(ui = ui, server = server)
But I'm having a lot of trouble combining the two. Partly due to my lack of JS knowledge.
Thanks and any help is much appreciated!
Just combine two javascript code that you provided in one datatable function. This should work:
library(shiny)
library(DT)
ui<-shinyUI(
mainPanel(
DT::dataTableOutput("tbl")
)
)
server<-shinyServer(function(input, output,session) {
shinyInput <- function(FUN, len, id, ivals, ...) {
inputs <- numeric(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(
FUN(paste0(id, i), label = NULL,
value=ivals[i],...)
)
}
inputs
}
it_df <- reactive({
data.frame(
Parameters = rep("X",5),
Values = shinyInput(numericInput, 5,
'param_values',
numeric(5),
width = '100%'),
stringsAsFactors = FALSE
)
})
output$tbl = DT::renderDataTable(
datatable(it_df(), escape = FALSE, options = list(
preDrawCallback = JS("function() { Shiny.unbindAll(this.api().table().node());}"),
drawCallback = JS("function() { Shiny.bindAll(this.api().table().node());}")
),
callback = JS("
var tips = ['First row name', 'Second row name', 'Third row name',
'Fourth row name', 'Fifth row name'],
firstColumn = $('#tbl tr td:first-child');
for (var i = 0; i < tips.length; i++) {
$(firstColumn[i]).attr('title', tips[i]);
}")), server = FALSE)
})
shinyApp(ui = ui, server = server)

shiny DT datatable with vertical radio button

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"]]
})
}
)

r- text input and checkbox in a datatable in shiny

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 );
});")
)
}
)

Radiobuttons in Shiny DataTable for "subselection" of rows/ grouping in one column

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

Categories