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