Shiny - checkbox in table in shiny
You can use DT
with , escape = FALSE
see
library(shiny)
library(DT)
mymtcars = mtcars
mymtcars$id = 1:nrow(mtcars)
runApp(
list(ui = pageWithSidebar(
headerPanel('Examples of DataTables'),
sidebarPanel(
checkboxGroupInput('show_vars', 'Columns to show:', names(mymtcars),
selected = names(mymtcars))
,textInput("collection_txt",label="Foo")
),
mainPanel(
DT::dataTableOutput("mytable")
)
)
, server = function(input, output, session) {
rowSelect <- reactive({
paste(sort(unique(input[["rows"]])),sep=',')
})
observe({
updateTextInput(session, "collection_txt", value = rowSelect() ,label = "Foo:" )
})
output$mytable = DT::renderDataTable({
addCheckboxButtons <- paste0('<input type="checkbox" name="row', mymtcars$id, '" value="', mymtcars$id, '">',"")
#Display table with checkbox buttons
DT::datatable(cbind(Pick=addCheckboxButtons, mymtcars[, input$show_vars, drop=FALSE]),
options = list(orderClasses = TRUE,
lengthMenu = c(5, 25, 50),
pageLength = 25,
callback = JS("function(table) {
table.on('change.dt', 'tr td input:checkbox', function() {
setTimeout(function () {
Shiny.onInputChange('rows', $(this).add('tr td input:checkbox:checked').parent().siblings(':last-child').map(function() {
return $(this).text();
}).get())
}, 10);
});
}")),escape = FALSE,
)
}
)
}
)
)
update
Make in other way using shinyinput
library(shiny)
library(DT)
mymtcars = mtcars
mymtcars$id = 1:nrow(mtcars)
runApp(
list(ui = pageWithSidebar(
headerPanel('Examples of DataTables'),
sidebarPanel(
checkboxGroupInput('show_vars', 'Columns to show:', names(mymtcars),
selected = names(mymtcars))
,textInput("collection_txt",label="Foo")
),
mainPanel(
DT::dataTableOutput("mytable")
)
)
, server = function(input, output, session) {
shinyInput <- function(FUN,id,num,...) {
inputs <- character(num)
for (i in seq_len(num)) {
inputs[i] <- as.character(FUN(paste0(id,i),label=NULL,...))
}
inputs
}
rowSelect <- reactive({
rows=names(input)[grepl(pattern = "srows_",names(input))]
paste(unlist(lapply(rows,function(i){
if(input[[i]]==T){
return(substr(i,gregexpr(pattern = "_",i)[[1]]+1,nchar(i)))
}
})))
})
observe({
updateTextInput(session, "collection_txt", value = rowSelect() ,label = "Foo:" )
})
output$mytable = DT::renderDataTable({
#Display table with checkbox buttons
DT::datatable(cbind(Pick=shinyInput(checkboxInput,"srows_",nrow(mymtcars),value=NULL,width=1), mymtcars[, input$show_vars, drop=FALSE]),
options = list(orderClasses = TRUE,
lengthMenu = c(5, 25, 50),
pageLength = 25 ,
drawCallback= JS(
'function(settings) {
Shiny.bindAll(this.api().table().node());}')
),selection='none',escape=F)
}
)
})
)
How to add checkbox in datatable in a shiny module?
Like this? (I don't see any problem regarding the module)
library(shiny)
library(DT)
ui <- fluidPage(
br(),
fluidRow(
column(
6,
DTOutput("dtable")
),
column(
6,
verbatimTextOutput("reactiveDF")
)
)
)
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
}
dat0 <- data.frame(
fruit = c("apple", "cherry", "pineapple", "pear"),
letter = c("a", "b", "c", "d")
)
dat1 <- cbind(dat0, bool = FALSE)
dat2 <- cbind(
dat0,
check = shinyInput(checkboxInput, nrow(dat0), "checkb")
)
js <- c(
"$('[id^=checkb]').on('click', function(){",
" var id = this.getAttribute('id');",
" var i = parseInt(/checkb(\\d+)/.exec(id)[1]);",
" var value = $(this).prop('checked');",
" var info = [{row: i, col: 3, value: value}];",
" Shiny.setInputValue('dtable_cell_edit:DT.cellInfo', info);",
"})"
)
server <- function(input, output, session) {
Dat <- reactiveVal(dat1)
output[["dtable"]] <- renderDT({
datatable(
dat2,
rownames = TRUE,
escape = FALSE,
editable = list(target = "cell", disable = list(columns = 3)),
selection = "none",
callback = JS(js)
)
}, server = FALSE)
observeEvent(input[["dtable_cell_edit"]], {
info <- input[["dtable_cell_edit"]] # this input contains the info of the edit
print(info)
Dat(editData(Dat(), info))
})
output[["reactiveDF"]] <- renderPrint({
Dat()
})
}
shinyApp(ui, server)
EDIT: with a module
library(shiny)
library(DT)
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
}
dat0 <- data.frame(
fruit = c("apple", "cherry", "pineapple", "pear"),
letter = c("a", "b", "c", "d")
)
dat1 <- cbind(dat0, bool = FALSE)
dat2 <- cbind(
dat0,
check = shinyInput(checkboxInput, nrow(dat0), "checkb")
)
js <- function(dtid, ns) {
c(
"$('[id^=checkb]').on('click', function(){",
" var id = this.getAttribute('id');",
" var i = parseInt(/checkb(\\d+)/.exec(id)[1]);",
" var value = $(this).prop('checked');",
" var info = [{row: i, col: 3, value: value}];",
sprintf(
"Shiny.setInputValue('%s', info);",
ns(sprintf("%s_cell_edit:DT.cellInfo", dtid))
),
"})"
)
}
tableUI <- function(id) {
ns <- NS(id)
fluidRow(
column(
6,
DTOutput(ns("dtable"))
),
column(
6,
verbatimTextOutput(ns("reactiveDF"))
)
)
}
tableServer <- function(id) {
moduleServer(id, function(input, output, session) {
Dat <- reactiveVal(dat1)
output[["dtable"]] <- renderDT(
{
datatable(
dat2,
rownames = TRUE,
escape = FALSE,
editable = list(target = "cell", disable = list(columns = 3)),
selection = "none",
callback = JS(js("dtable", session$ns))
)
},
server = FALSE
)
observeEvent(input[["dtable_cell_edit"]], {
info <- input[["dtable_cell_edit"]]
Dat(editData(Dat(), info))
})
output[["reactiveDF"]] <- renderPrint({
Dat()
})
})
}
ui <- fluidPage(
br(),
tableUI("xxx")
)
server <- function(input, output, session) {
tableServer("xxx")
}
shinyApp(ui, server)
EDIT: multiple pages
If there is more than one page, replace
js <- function(dtid, ns) {
c(
"$('[id^=checkb]').on('click', function(){",
" var id = this.getAttribute('id');",
" var i = parseInt(/checkb(\\d+)/.exec(id)[1]);",
" var value = $(this).prop('checked');",
" var info = [{row: i, col: 3, value: value}];",
sprintf(
"Shiny.setInputValue('%s', info);",
ns(sprintf("%s_cell_edit:DT.cellInfo", dtid))
),
"})"
)
}
with
js <- function(dtid, ns) {
c(
"$('body').on('click', '[id^=checkb]', function(){",
" var id = this.getAttribute('id');",
" var i = parseInt(/checkb(\\d+)/.exec(id)[1]);",
" var value = $(this).prop('checked');",
" var info = [{row: i, col: 3, value: value}];",
sprintf(
"Shiny.setInputValue('%s', info);",
ns(sprintf("%s_cell_edit:DT.cellInfo", dtid))
),
"})"
)
}
Shiny - checkboxInput within renderDataTable does not work
You can use the DT package (based on this):
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
fluidRow(
column(12,dataTableOutput('dataTableOutput')),
column(12,tableOutput('tableOutput')),
actionButton('printCheckStatus','printCheckStatus')
)
),
server = function(input, output) {
df1 <- data.frame(CheckBoxColumn=as.character(checkboxInput("id_1",NULL)))
df2 <- data.frame(CheckBoxColumn=as.character(checkboxInput("id_2",NULL)))
output$dataTableOutput <- renderDataTable(df1,escape = FALSE, server = FALSE,
callback = JS("table.cells().every(function(i, tab, cell) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-checkbox');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());"))
output$tableOutput <- renderTable(df2, sanitize.text.function = function(x) x)
observeEvent(input$printCheckStatus, {print(input$id_1);print(input$id_2)})
}
)
R shiny DT checkboxes on top to tick/untick all the checkboxes below
Something like that:
library(DT)
dat <- data.frame(
vapply(1:10, function(i){
as.character(
checkboxInput(paste0("cbox2018-", i), label = NULL, width = "150px")
)
}, character(1)),
rpois(10, 100),
rpois(10, 50)
)
names(dat) <- c(
as.character(
checkboxInput("cbox2018", label = "2018", width = "150px")
),
"foo",
"bar"
)
datatable(
dat,
escape = FALSE,
options = list(
columnDefs = list(
list(targets = 1, orderable = FALSE, className = "dt-center")
)
),
callback = JS(
"$('#cbox2018').on('click', function(){",
" var cboxes = $('[id^=cbox2018-]');",
" var checked = $('#cbox2018').is(':checked');",
" cboxes.each(function(i, cbox) {",
" $(cbox).prop('checked', checked);",
" });",
"});"
)
)
And add the preDrawCallback
and the drawCallback
for Shiny.
EDIT
As noted by @Olivier in a comment, the box-checking is performed on the current page only. Here is a solution to this issue:
library(shiny)
library(DT)
dat <- data.frame(
vapply(1:100, function(i){
as.character(
checkboxInput(paste0("cbox2018-", i), label = NULL, width = "150px")
)
}, character(1)),
rpois(100, 100),
rpois(100, 50)
)
names(dat) <- c(
as.character(
checkboxInput("cbox2018", label = "2018", width = "150px")
),
"foo",
"bar"
)
ui <- basicPage(
br(),
DTOutput("dtable")
)
server <- function(input, output, session){
output[["dtable"]] <- renderDT({
datatable(
dat,
escape = FALSE,
options = list(
columnDefs = list(
list(targets = 1, orderable = FALSE, className = "dt-center")
),
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
),
callback = JS(
"$('#cbox2018').on('click', function(){",
" var cboxes = $('[id^=cbox2018-]');",
" var checked = $('#cbox2018').is(':checked');",
" cboxes.each(function(i, cbox) {",
" $(cbox).prop('checked', checked);",
" });",
"});",
"table.on('page.dt', function(){",
" setTimeout(function(){",
" var cboxes = $('[id^=cbox2018-]');",
" var checked = $('#cbox2018').is(':checked');",
" cboxes.each(function(i, cbox) {",
" $(cbox).prop('checked', checked);",
" });",
" });",
"});"
)
)
}, server = FALSE)
}
shinyApp(ui, server)
Datatable in Shiny with checkboxes and pagination
Here is a way:
library(shiny)
library(DT)
mymtcars <- mtcars
mymtcars[["Select"]] <- paste0('<input type="checkbox" name="row_selected" value=',1:nrow(mymtcars),' checked>')
mymtcars[["_id"]] <- paste0("row_", seq(nrow(mymtcars)))
callback <- c(
sprintf("table.on('click', 'td:nth-child(%d)', function(){",
which(names(mymtcars) == "Select")),
" var checkbox = $(this).children()[0];",
" var $row = $(this).closest('tr');",
" if(checkbox.checked){",
" $row.removeClass('excluded');",
" }else{",
" $row.addClass('excluded');",
" }",
" var excludedRows = [];",
" table.$('tr').each(function(i, row){",
" if($(this).hasClass('excluded')){",
" excludedRows.push(parseInt($(row).attr('id').split('_')[1]));",
" }",
" });",
" Shiny.setInputValue('excludedRows', excludedRows);",
"});"
)
ui = fluidPage(
verbatimTextOutput("excludedRows"),
DTOutput('myDT')
)
server = function(input, output) {
output$myDT <- renderDT({
datatable(
mymtcars, selection = "multiple",
options = list(pageLength = 5,
lengthChange = FALSE,
rowId = JS(sprintf("function(data){return data[%d];}",
ncol(mymtcars)-1)),
columnDefs = list( # hide the '_id' column
list(visible = FALSE, targets = ncol(mymtcars)-1)
)
),
rownames = FALSE,
escape = FALSE,
callback = JS(callback)
)
}, server = FALSE)
output$excludedRows <- renderPrint({
input[["excludedRows"]]
})
}
shinyApp(ui,server, options = list(launch.browser = TRUE))
Using Shiny and checkboxGroupInput to update a table via bind_rows or rbind and using if else statements
input$overall_boxes
may contain multiple elements, so that you should use %in%
instead of ==
in the if
statement.
Try:
library(shiny)
library(tidyverse)
table_math <- data.frame(age = c(5,10), test = "math", result = rnorm(100,10,2))
table_science <- data.frame(age = c(10,15), test = "science", result = rnorm(100,8,2))
table_litterature <- data.frame(age = c(5,15), test = "litterature", result = rnorm(100,5,2))
# Define UI for application that draws a histogram
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
checkboxGroupInput("overall_boxes", label = h3("This is a Checkbox group"),
choices = list("Math" = "math", "Sciences" = "sci", "Litterature" = "lit"),
selected = "math")
),
# Show a plot of the generated distribution
mainPanel(
dataTableOutput("main_results")
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
#backend
merge_results <- reactive({
bind_rows(
if ("math" %in% input$overall_boxes) { table_math } else { table_math[F,] }, #when I click "math" is shows the math results
if ("sci" %in% input$overall_boxes) { table_science } else { table_science[F,] } ,#when I click "sci" is shows the science results (and keep the math if math is selected)
if ("lit" %in% input$overall_boxes) { table_litterature } else { table_litterature[F,]}
)
})
#real output
output$main_results <- renderDataTable(
merge_results()
)
}
# Run the application
shinyApp(ui = ui, server = server)
R Shiny: Update datatable with checkbox
You have to unbind the previously created Shiny objects before creating the new table, when you click on a point. For example with shinyjs
:
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
fluidRow(
......
observeEvent(input$plot_click, {
runjs("Shiny.unbindAll($('#table').find('table').DataTable().table().node());")
x$x <- c(x$x,input$plot_click$x)
y$y <- c(y$y,input$plot_click$y)
})
Related Topics
How to Extend Letters Past 26 Characters E.G., Aa, Ab, Ac...
Reading Big Data with Fixed Width
Source Script to Separate Environment in R, Not the Global Environment
How to Reorder the Items in a Legend
Convert Accented Characters into Ascii Character
R - Ggplot2 - Highlighting Selected Points and Strange Behavior
Collapse All Columns by an Id Column
How to Use a Graphic Imported with Grimport as Axis Tick Labels in Ggplot2 (Using Grid Functions)
Remove Lines from Color and Fill Legends
Get the Index of the Values of One Vector in Another
Index Unique Values in Data.Table
Ggplot: Order Bars in Faceted Bar Chart Per Facet
Shiny - Checkbox in Table in Shiny
Ggplot2 - Using Two Different Color Scales for Overlayed Plots
Best Way to Replace a Lengthy Ifelse Structure in R
Dynamic Linking with Rpath Not Working Under Ubuntu 17.10