Shiny - Checkbox in Table in Shiny

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)

Sample Image



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

Sample Image

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

Sample Image

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

Sample Image



Related Topics



Leave a reply



Submit