Shiny datatable mode editable - restrict specific columns AND ROWS - r

I would like to restrict editable mode in datatable for columns and rows.
For the moment, in this minimal example, I can edit only specific columns but it doesn't work for restrict rows (not allow rows 1 to 5).
Does anyone have an idea?
Thank you for advance
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(DTOutput('tbl')),
server = function(input, output) {
output$tbl = renderDT(
datatable(data = iris,
options = list(lengthChange = FALSE),
editable = list(target = 'column', disable = list(columns = c(1:3), rows = c(1:5))))
)
}
)

You can adapt the code from the link I provided as shown below.
library(shiny)
library(DT)
disabled_rows = paste0("'", paste0("row", c(1,2,3)), "'") ### disabled rows are listed here
rowCallback <- c(
"function(row, data, displayNum, displayIndex){",
sprintf(" var indices = [%s];", toString(disabled_rows)),
" if(indices.indexOf($(row).attr('id')) > - 1){",
" $(row).find('td').addClass('notselectable').css({'background-color': '#eee', 'color': '#bbb'});",
" }",
"}"
)
get_selected_rows <- c(
"var id = $(table.table().node()).closest('.datatables').attr('id');",
"table.on('click', 'tbody', function(){",
" setTimeout(function(){",
" var indexes = table.rows({selected:true}).indexes();",
" var indices = Array(indexes.length);",
" for(var i = 0; i < indices.length; ++i){",
" indices[i] = indexes[i];",
" }",
" Shiny.setInputValue(id + '_rows_selected', indices);",
" }, 0);",
"});"
)
drag_selection <- c(
"var dt = table.table().node();",
"$(dt).selectable({",
" distance : 10,",
" selecting: function(evt, ui){",
" $(this).find('tbody tr').each(function(i){",
" if($(this).hasClass('ui-selecting')){",
" table.row(i).select();",
" }",
" });",
" }",
"}).on('dblclick', function(){table.rows().deselect();});"
)
dat <- iris
dat$ID <- paste0("row", 1:nrow(iris))
rowNames <- TRUE
colIndex <- as.integer(rowNames)
shinyApp(
ui = fluidPage(DTOutput('tbl')),
server = function(input, output, session) {
### disable selected rows only
# output$tbl <- renderDT({
#
# datatable(
# dat,
# rownames = rowNames,
# callback = JS(get_selected_rows),
# class = 'hover row-border order-column',
# options = list(
# rowId = JS(sprintf("function(data){return data[%d];}",
# ncol(dat)-1+colIndex)),
# rowCallback = JS(rowCallback),
# select = list(style = "multi", selector = "td:not(.notselectable)")
# ),
# extensions = "Select", selection = 'none'
# )
# }, server = TRUE)
### disable selected rows and columns
output$tbl <- renderDT({
datatable(
dat,
rownames = rowNames,
callback = JS(get_selected_rows),
class = 'hover row-border order-column',
options = list(
lengthChange = FALSE,
rowId = JS(sprintf("function(data){return data[%d];}",
ncol(dat)-1+colIndex)),
rowCallback = JS(rowCallback),
select = list(style = "multi", selector = "td:not(.notselectable)")
),
extensions = "Select",
editable = list(target = 'column', disable = list(columns = c(2:3) )), selection = 'none',
)
}, server = TRUE)
### disable selected columns only
# output$tbl = renderDT(
# datatable(data = iris,
# options = list(lengthChange = FALSE),
# #extensions = "Select", selection = 'none',
# editable = list(target = 'column', disable = list( columns = c(2:3) )) )
# )
}
)

Related

How to update row-wise filter in Shiny datatable

I'm trying to update row-wise filter in datatable basis on the inputs we receive from user on every row, so that only relevant values in sub-sequent inputs can be selected.
I have tried to replicate my scenario using below code, where in if User selects "setosa" as "spieces_selector" hence only "1-50" values should appear in "New_Data_selector". Similarly if a User selects "versicolor" in 2nd row hence for 2nd row "New_Data_selector" should have the values from "51-100".
Would appreciate your help on this.
library(shiny)
library(DT)
iris$New_Data <- c(1:150)
ui <- fluidPage(
title = 'Selectinput column in a table',
h3("Source:", tags$a("Yihui Xie", href = "https://yihui.shinyapps.io/DT-radio/")),
numericInput('num', "enter a number", value = 5, min = 1, max = 10, step = 1),
DT::dataTableOutput('foo'),
verbatimTextOutput('sel'),
actionButton(
"saveBtn",
"Submit Request",
style = "color: #fff; background-color: #282364;
border-color: #2e6da4",
class = "btn btn-primary"
)
)
server <- function(input, output, session) {
data <- reactive({
df <- head(iris, input$num)
for (i in 1:nrow(df)) {
df$species_selector[i] <- as.character(selectInput(paste0("sel1", i),
"",
choices = unique(iris$Species),
width = "100px"))
df$New_Data_selector[i] <- as.character(selectInput(paste0("sel2", i),
"",
choices = unique(iris$New_Data),
width = "100px"))
}
df
})
output$foo = DT::renderDataTable(
data(), 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-container');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());")
)
output$sel = renderPrint({
str(sapply(1:nrow(data()), function(i) input[[paste0("sel", i)]]))
})
observeEvent(input$saveBtn, {
Test_Data <- sapply(1:nrow(data()), function(i) input[[paste0("sel", i)]])
Test_Data <- as.data.frame(Test_Data)
print(Test_Data)})
}
shinyApp(ui, server)
The following works (based on my earlier answer) - but it's pretty slow. Will need to investigate further.
library(DT)
library(shiny)
library(datasets)
library(data.table)
myIris <- copy(iris)
setDT(myIris)
myIris[, Index := seq_len(.N)]
selectInputIDs_A <- paste0("sel_A", myIris$Index)
selectInputIDs_B <- paste0("sel_B", myIris$Index)
myIris[, selectInputs_A := sapply(selectInputIDs_A, function(x){as.character(selectInput(inputId = x, label = "", choices = unique(myIris$Species), selected = "setosa"))})]
myIris[, selectInputs_B := sapply(selectInputIDs_B, function(x){as.character(selectInput(inputId = x, label = "", choices = unique(myIris[Species == "setosa"]$Index), selected = "setosa"))})]
initTbl <- copy(myIris)
ui <- fluidPage(
DT::dataTableOutput(outputId = 'my_table')
)
server <- function(input, output, session) {
displayTbl <- reactive({
myIris[, selectInputs_A := sapply(selectInputIDs_A, function(x){as.character(selectInput(inputId = x, label = "", choices = unique(Species), selected = input[[x]]))}),]
myIris[, selectInputs_B := sapply(seq_along(selectInputs_B), function(x){as.character(selectInput(inputId = selectInputIDs_B[x], label = "", choices = unique(myIris[Species == input[[selectInputIDs_A[x]]]]$Index), selected = input[[selectInputIDs_A[x]]]))})]
})
output$my_table = DT::renderDataTable({
DT::datatable(
initTbl, escape = FALSE, selection = 'none', rownames = FALSE,
options = list(paging = FALSE, ordering = FALSE, scrollx = TRUE, dom = "t",
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
)
)
}, server = TRUE)
my_table_proxy <- dataTableProxy(outputId = "my_table", session = session)
observeEvent({sapply(selectInputIDs_A, function(x){input[[x]]})}, {
replaceData(proxy = my_table_proxy, data = displayTbl(), rownames = FALSE) # must repeat rownames = FALSE see ?replaceData and ?dataTableAjax
}, ignoreInit = TRUE)
}
shinyApp(ui = ui, server = server)

Add background color to DT rows in shiny

I have some code that creates a DT table with radio buttons. On top of that I need to add particular colors to each row. I have been trying to use formatStyle too add a different color to each row but I haven't gotten the syntax correct.
Here is the working code:
library(shiny)
library(DT)
c1 = "This is comment 1"
c2 = "This is comment 2"
c3 = "This is comment 3"
c4 = "This is comment 4"
c5 = "This is comment 5"
comments1 = list(c1,c2,c3,c4,c5)
m1 = matrix(
as.character(1:5), nrow = 5, ncol = 1, byrow = FALSE,
dimnames = list(comments1, LETTERS[1])
)
for (i in seq_len(ncol(m1))) {
m1[, i] = sprintf(
'<input type="radio" name="%s" value="%s"/>',
'AValue', m1[,i]
)
}
callback1 <- c(
"var LETTERS = ['AValue'];",
"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);",
" });",
"}"
)
ui <- fluidPage(
title = 'Radio buttons in a table',
DT::dataTableOutput('foo1'),
verbatimTextOutput('sel1'),
)
server <- function(input, output, session) {
output$foo1 = DT::renderDataTable(
m1, escape = FALSE, selection = 'none', server = FALSE,
options = list(dom = 't', paging = FALSE, ordering = FALSE),
callback = JS(callback1),
)
output$sel1 = renderPrint({
input[["AValue"]]
})
}
shinyApp(ui, server)
Here are the some of the different variations of the calls that I have tried.
#formatStyle needs to be called on DT:datatable()
#Test adding formatStyle
output$foo1 <- DT::renderDataTable({
dat <- datatable(m1, escape = FALSE, selection = 'none',
options = list(dom = 't', paging = FALSE, ordering = FALSE))
callback = JS(callback1) %>% formatStyle(0, target='row', backgroundColor = styleEqual(3,'red'))
})
or
#Test adding formatStyle
output$foo1 <- DT::renderDataTable({
DT::datatable(m1,escape = FALSE, selection = 'none',
options = list(dom = 't', paging = FALSE, ordering = FALSE, callback = JS(callback1))
%>% formatStyle(0, target='row', backgroundColor = styleEqual(3,'red')))
})
Any help would be greatly appreciated.
Thanks!
You need to pass the table as an argument of the formatStyle. To do that inside the renderDataTable you can use the datatable function.
It seems that your condition to assign a color to a row is not going to match any row. You need to put something that could be in the column. Below is an example where an entire row has a red background when the content in column 0 is equal to "This is comment 3".
output$foo1 = DT::renderDataTable({
DT::datatable(
m1, escape = FALSE, selection = 'none',
options = list(dom = 't', paging = FALSE, ordering = FALSE),
callback = JS(callback1)
) %>% formatStyle(0, target='row', backgroundColor = styleEqual('This is comment 3','red'))
}, server = FALSE
)
Perhaps you can define a new column with row_numbers and assign colors to the rows of interest. You can make the row_num column not visible. Try this
mycolors <- c('green','pink','red','yellow','orange')
output$foo1 = DT::renderDataTable({
m2 <- as.data.frame(m1) %>% dplyr::mutate(row_num = 1:n())
datatable( m2, escape = FALSE,
selection = 'none',
extensions = c("Select", "Buttons"),
callback = JS(callback1), ### needs double-click to select the radiobutton
options = list(dom = 't', paging = FALSE, ordering = FALSE,
columnDefs = list(list(visible=FALSE, targets=2))
)
) %>% formatStyle(2,
target='row',
backgroundColor = styleEqual(c(1:5),mycolors))
}, server = FALSE,
#callback = JS(callback1) ### does not recognize input[["AValue"]]
)

Display multiple strings in a cell of a datatable that can be removed by clicking on them

I have the shiny app below in which I convert the d dataframe to a dataframe in which the unique items will be summarized based on the name and a new column will be added with their count. Then I use DT package to display this dataframe. I wonder if DT or shinywidgets or maybe another method can be used in order to display the table like in the screenshot below in which the user will be able to display the different strings in the items column as separated words that he will be able to remove. Here is an example in the second column.
library(shiny)
library(DT)
library(jsonlite)
selector <- function(id, values, items = values){
options <- HTML(paste0(mapply(
function(value, item){
as.character(tags$option(value = value, item))
}, c("", values), c("", items)
), collapse = ""))
as.character(
tags$select(
id = id, class = "form-control", multiple = "multiple", options
)
)
}
name<-c("Jack","Bob","Jack","Bob")
item<-c("apple","olive","banana","tomato")
d<-data.frame(name,item)
words<-tapply(d$item, d$name, I)
nrows <- length(words)
js <- c(
"function(settings) {",
sprintf("var nrows = %d;", nrows),
sprintf("var words = %s;", toJSON(words)),
" var table = this.api().table();",
" function selectize(i) {",
" $('#slct' + i).selectize({",
" items: words[i-1],",
" onChange: function(value) {",
" table.cell(i-1, 2).data(value.length);",
" }",
" });",
" }",
" for(var i = 1; i <= nrows; i++) {",
" selectize(i);",
" Shiny.setInputValue('slct' + i, words[i-1]);",
" }",
"}"
)
ui <- fluidPage(
br(),
DTOutput("table"),
div( # this is a hidden selectize input whose role is to make
# available 'selectize.js'
style = "display: none;",
selectInput("id", "label", c("x", "y"))
)
)
server <- function(input, output, session) {
output[["table"]] <- renderDT({
dat <- data.frame(
FOO = c(unique(d$name)),
Words = vapply(
1:nrows,
function(i){
selector(paste0("slct", i), words[[i]])
},
character(1)
),
Count = lengths(words),
stringsAsFactors = FALSE
)
datatable(
data = dat,
selection = "none",
escape = FALSE,
rownames = FALSE,
options = list(
initComplete = JS(js),
preDrawCallback = JS(
'function() { Shiny.unbindAll(this.api().table().node()); }'
),
drawCallback = JS(
'function() { Shiny.bindAll(this.api().table().node()); }'
)
)
)
}, server = FALSE)
}
shinyApp(ui, server)
We can do that with a selectizeInput:
library(shiny)
library(DT)
js <- c(
"function(settings){",
" $('#mselect').selectize();",
"}"
)
ui <- fluidPage(
br(),
DTOutput("table"),
div(
style = "display: none;",
selectInput("id", "label", c("x", "y"))
)
)
server <- function(input, output, session) {
output[["table"]] <- renderDT({
dat <- data.frame(
FOO = "bar",
BAZ = '<select id="mselect" class="form-control" multiple="multiple">
<option value=""></option>
<option value="A">Apple</option>
<option value="B">Banana</option>
<option value="C">Lemon</option>
</select>',
stringsAsFactors = FALSE)
datatable(
data = dat,
selection = "none",
escape = FALSE,
rownames = FALSE,
options = list(
initComplete = JS(js)
)
)
})
}
shinyApp(ui, server)
EDIT
library(shiny)
library(DT)
selector <- function(id, values, items = values){
options <- HTML(paste0(mapply(
function(value, item){
as.character(tags$option(value = value, item))
}, c("",values), c("",items)
), collapse = ""))
as.character(
tags$select(
id = id, class = "form-control", multiple = "multiple", options
)
)
}
words1 <- c("apple", "banana")
words2 <- c("olive", "tomato")
js <- c(
"function(settings) {",
sprintf("var words1 = [%s];", toString(shQuote(words1))),
sprintf("var words2 = [%s];", toString(shQuote(words2))),
" $('#slct1').selectize({items: words1});",
" $('#slct2').selectize({items: words2});",
" Shiny.setInputValue('slct1', words1);",
" Shiny.setInputValue('slct2', words2);",
"}"
)
ui <- fluidPage(
br(),
verbatimTextOutput("words1"),
DTOutput("table"),
div( # this is a hidden selectize input whose role is to make
# available 'selectize.js'
style = "display: none;",
selectInput("id", "label", c("x", "y"))
)
)
server <- function(input, output, session) {
output[["table"]] <- renderDT({
dat <- data.frame(
FOO = c("bar", "baz"),
Words = c(
selector("slct1", words1),
selector("slct2", words2)
),
stringsAsFactors = FALSE
)
datatable(
data = dat,
selection = "none",
escape = FALSE,
rownames = FALSE,
options = list(
initComplete = JS(js),
preDrawCallback = JS(
'function() { Shiny.unbindAll(this.api().table().node()); }'
),
drawCallback = JS(
'function() { Shiny.bindAll(this.api().table().node()); }'
)
)
)
}, server = FALSE)
output[["words1"]] <- renderPrint({
input[["slct1"]]
})
}
shinyApp(ui, server)
EDIT
With the counts:
library(shiny)
library(DT)
selector <- function(id, values, items = values){
options <- HTML(paste0(mapply(
function(value, item){
as.character(tags$option(value = value, item))
}, c("",values), c("",items)
), collapse = ""))
as.character(
tags$select(
id = id, class = "form-control", multiple = "multiple", options
)
)
}
words1 <- c("apple", "banana")
words2 <- c("olive", "tomato")
js <- c(
"function(settings) {",
sprintf("var words1 = [%s];", toString(shQuote(words1))),
sprintf("var words2 = [%s];", toString(shQuote(words2))),
" var table = this.api().table();",
" $('#slct1').selectize({",
" items: words1,",
" onChange: function(value) {",
" var count = value.length;",
" table.cell(0,2).data(count);",
" }",
" });",
" $('#slct2').selectize({",
" items: words2,",
" onChange: function(value) {",
" var count = value.length;",
" table.cell(1,2).data(count);",
" }",
" });",
" Shiny.setInputValue('slct1', words1);",
" Shiny.setInputValue('slct2', words2);",
"}"
)
ui <- fluidPage(
br(),
verbatimTextOutput("words1"),
DTOutput("table"),
div( # this is a hidden selectize input whose role is to make
# available 'selectize.js'
style = "display: none;",
selectInput("id", "label", c("x", "y"))
)
)
server <- function(input, output, session) {
output[["table"]] <- renderDT({
dat <- data.frame(
FOO = c("bar", "baz"),
Words = c(
selector("slct1", words1),
selector("slct2", words2)
),
Count = c(length(words1), length(words2)),
stringsAsFactors = FALSE
)
datatable(
data = dat,
selection = "none",
escape = FALSE,
rownames = FALSE,
options = list(
initComplete = JS(js),
preDrawCallback = JS(
'function() { Shiny.unbindAll(this.api().table().node()); }'
),
drawCallback = JS(
'function() { Shiny.bindAll(this.api().table().node()); }'
)
)
)
}, server = FALSE)
output[["words1"]] <- renderPrint({
input[["slct1"]]
})
}
shinyApp(ui, server)
EDIT
For an arbitrary number of rows:
library(shiny)
library(DT)
library(jsonlite)
selector <- function(id, values, items = values){
options <- HTML(paste0(mapply(
function(value, item){
as.character(tags$option(value = value, item))
}, c("", values), c("", items)
), collapse = ""))
as.character(
tags$select(
id = id, class = "form-control", multiple = "multiple", options
)
)
}
words <- list(
c("apple", "banana"),
c("olive", "tomato")
)
nrows <- length(words)
js <- c(
"function(settings) {",
sprintf("var nrows = %d;", nrows),
sprintf("var words = %s;", toJSON(words)),
" var table = this.api().table();",
" function selectize(i) {",
" $('#slct' + i).selectize({",
" items: words[i-1],",
" onChange: function(value) {",
" table.cell(i-1, 2).data(value.length);",
" }",
" });",
" }",
" for(var i = 1; i <= nrows; i++) {",
" selectize(i);",
" Shiny.setInputValue('slct' + i, words[i-1]);",
" }",
"}"
)
ui <- fluidPage(
br(),
verbatimTextOutput("words1"),
DTOutput("table"),
div( # this is a hidden selectize input whose role is to make
# available 'selectize.js'
style = "display: none;",
selectInput("id", "label", c("x", "y"))
)
)
server <- function(input, output, session) {
output[["table"]] <- renderDT({
dat <- data.frame(
FOO = c("bar", "baz"),
Words = vapply(
1:nrows,
function(i){
selector(paste0("slct", i), words[[i]])
},
character(1)
),
Count = lengths(words),
stringsAsFactors = FALSE
)
datatable(
data = dat,
selection = "none",
escape = FALSE,
rownames = FALSE,
options = list(
initComplete = JS(js),
preDrawCallback = JS(
'function() { Shiny.unbindAll(this.api().table().node()); }'
),
drawCallback = JS(
'function() { Shiny.bindAll(this.api().table().node()); }'
)
)
)
}, server = FALSE)
output[["words1"]] <- renderPrint({
input[["slct1"]]
})
}
shinyApp(ui, server)
Here is another version. It uses the JavaScript library select2 instead of selectize. I find this one more convenient for the removal of the selected options: they are removed on clicking, while with selectize one needs the keyboard to remove an option.
library(shiny)
library(DT)
selector <- function(id, values, items = values){
options <- HTML(paste0(mapply(
function(value, item){
as.character(tags$option(value = value, selected = "selected", item))
}, values, items
), collapse = ""))
as.character(
tags$select(
id = id, multiple = "multiple", options
)
)
}
words <- list(
c("apple", "banana"),
c("olive", "tomato")
)
nrows <- length(words)
js <- c(
"function(settings) {",
sprintf("var nrows = %d;", nrows),
" var table = this.api().table();",
" function selectize(i) {",
" var $slct = $('#slct' + i);",
" $slct.select2({",
" width: '100%',",
" closeOnSelect: false",
" });",
" $slct.on('change', function(e) {",
" table.cell(i-1, 2).data($slct.val().length);",
" });",
" }",
" for(var i = 1; i <= nrows; i++) {",
" selectize(i);",
" }",
"}"
)
ui <- fluidPage(
tags$head(
tags$link(rel = "stylesheet", href = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/css/select2.min.css"),
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/js/select2.min.js")
),
br(),
verbatimTextOutput("words1"),
DTOutput("table")
)
server <- function(input, output, session) {
output[["table"]] <- renderDT({
dat <- data.frame(
FOO = c("bar", "baz"),
Words = vapply(
1:nrows,
function(i){
selector(paste0("slct", i), words[[i]])
},
character(1)
),
Count = lengths(words),
stringsAsFactors = FALSE
)
datatable(
data = dat,
selection = "none",
escape = FALSE,
rownames = FALSE,
options = list(
initComplete = JS(js),
preDrawCallback = JS(
'function() { Shiny.unbindAll(this.api().table().node()); }'
),
drawCallback = JS(
'function() { Shiny.bindAll(this.api().table().node()); }'
)
)
)
}, server = FALSE)
output[["words1"]] <- renderPrint({
input[["slct1"]]
})
}
shinyApp(ui, server)

DT export without format R Shiny

I am exporting data with the button extension of DT. When clicking on copy or excel or pdf, format is also exported.
DT version 0.14 include format contrary to the old version 0.5 that is the comportement needed.
Reproducible exemple, Sepal.Width column with unit in meters in table that I don't want to export :
library(shiny)
library(DT)
ui <- fluidPage(
dataTableOutput("dt_table")
)
server <- function(input, output) {
output$dt_table <- renderDataTable({
datatable(
iris,
options = list(dom = 'lBfrtip', buttons = c('copy','excel', 'pdf')),
extensions = 'Buttons'
) %>% formatString(
columns = 'Sepal.Width',
suffix = " meters"
)
})
}
shinyApp(ui = ui, server = server)
Do you know any argument to export dataset without formating ?
Thanks for any help.
Here is a way:
library(shiny)
library(DT)
ui <- fluidPage(
DTOutput("dt_table")
)
render <- c(
"function(data, type, row, meta){",
" if(type === 'display'){",
" return data + ' meters';",
" }else{",
" return data;",
" }",
"}"
)
server <- function(input, output) {
output$dt_table <- renderDT({
datatable(
iris,
options = list(
dom = 'lBfrtip',
buttons = list(
list(
extend = "copy",
exportOptions = list(orthogonal = "export")
),
list(
extend = "excel",
exportOptions = list(orthogonal = "export")
),
list(
extend = "pdf",
exportOptions = list(orthogonal = "export")
)
),
columnDefs = list(
list(targets = 2, render = JS(render))
)
),
extensions = 'Buttons'
)
})
}
shinyApp(ui = ui, server = server)
EDIT
Another way:
tplString2 <- function(prefix, suffix, ...) {
sprintf(
"type === 'display' ? DTWidget.formatString(data, %s, %s) : data;",
DT:::jsValues(prefix), DT:::jsValues(suffix)
)
}
formatString2 <- function(table, columns, prefix = '', suffix = '') {
DT:::formatColumns(table, columns, tplString2, prefix, suffix)
}
tplDate2 <- function(method, params, ...) {
params = if (length(params) > 0) paste(',', jsonlite::toJSON(params)) else ''
sprintf(
"type === 'display' ? DTWidget.formatDate(data, %s%s) : data;",
DT:::jsValues(method), params
)
}
formatDate2 <- function(table, columns, method = 'toDateString', params = NULL) {
if (!inherits(table, 'datatables'))
stop("Invalid table argument; a table object created from datatable() was expected")
x = table$x
if (x$filter != 'none') {
if (inherits(columns, 'formula')) columns = all.vars(columns)
colnames = base::attr(x, 'colnames', exact = TRUE)
rownames = base::attr(x, 'rownames', exact = TRUE)
if (is.null(params)) params = list()
cols = sprintf("%d", DT:::name2int(columns, colnames, rownames))
x$filterDateFmt = as.list(x$filterDateFmt)
for (col in cols) x$filterDateFmt[[col]] = list(
method = method, params = jsonlite::toJSON(params)
)
table$x = x
}
DT:::formatColumns(table, columns, tplDate2, method, params)
}
library(shiny)
library(DT)
server <- function(input, output) {
output$dt_table <- renderDT({
datatable(
iris,
options = list(
dom = 'lBfrtip',
buttons = list(
list(
extend = "copy",
exportOptions = list(orthogonal = "export")
),
list(
extend = "excel",
exportOptions = list(orthogonal = "export")
),
list(
extend = "pdf",
exportOptions = list(orthogonal = "export")
)
)
),
extensions = 'Buttons'
) %>%
formatString2(columns = 1, suffix = " meters")
})
}

How to avoid mixup between rowcallback and sorting in datatable

With the help of a previous question, I can now style selected rows (intended for the user to select rows to be excluded from further analysis), but I have found out that sorting the datatable after executing the functionality to exclude rows (gray them out and add a different icon, keeps the icon in the correct row, but grays out the wrong rows.
here is the table after deselecting rows 2,3 and 4 before sorting:
and after sort: (with the crosses at the right rows, but the graying out not.
library(shiny)
library(DT)
mtcars <- as.data.table(mtcars[1:15, )
ui <- fluidPage(
# actionButton('SubmitRemoval', 'Exclude selected rows'),
# actionButton('UndoRemoval', 'Include full data'),
# br(),
DTOutput('metadataTable')
)
server <- function(input, output,session) {
values <- reactiveValues()
rowCallbackMeta = function(rows){
c(
"function(row, data, num, index){",
sprintf(" var rows = [%s];", paste0(rows-1, collapse = ",")),
" if(rows.indexOf(num) > -1){",
" for(var i=0; i<data.length; i++){",
" $('td:eq('+i+')', row)",
" .css({'color': 'rgb(211,211,211)', 'font-style': 'italic'});",
" }",
" }",
" $('td:eq(3)', row).html(data[3].toExponential(2));",
"}"
)
}
output$metadataTable <- DT::renderDataTable({
rows <- values$RowsRemove
# mtcars1 <- cbind(Selected ='<span style = "color:#31C769 ; font-size:18px"><i class="fa fa-check"></i></span>', mtcars)
mtcars1 <- cbind(Selected ='<span style = "color:red ; font-size:18px"><i class="glyphicon glyphicon-ok"></i></span>', mtcars)
print(rows)
# if(!is.null(rows)) {
mtcars1$Selected[rows] <- '<span style = "color:red ; font-size:18px"><i class="glyphicon glyphicon-remove"></i></span>'
# }
Table_opts <- list(
dom = 'frtipB',
searching = F,
pageLength = 50,
searchHighlight = TRUE,
colReorder = TRUE,
fixedHeader = TRUE,
buttons = list('copy', 'csv',
list(
extend = "collection",
text = 'Deselect',
action = DT::JS("function ( e, dt, node, config ) {
Shiny.setInputValue('SubmitRemoval', true, {priority: 'event'});
}")
),
list(
extend = "collection",
text = 'Restore',
action = DT::JS("function ( e, dt, node, config ) {
Shiny.setInputValue('UndoRemoval', true, {priority: 'event'});
}")
)
),
paging = TRUE,
deferRender = TRUE,
columnDefs = list(list(className = 'dt-right', targets = '_all')),
rowCallback = JS(rowCallbackMeta(rows)),
scrollX = T,
scrollY = 440
)
DT::datatable(mtcars1,
escape = FALSE,
extensions = c('Buttons', 'ColReorder', 'FixedHeader', 'Scroller'),
selection = c('multiple'),
rownames = FALSE
,
options = Table_opts
)
})
observeEvent(values$RowsRemove, {
print('seeing rows remove')
values$Datafiles_meta_Selected <- values$Datafiles_meta_Selected[-c(values$RowsRemove),]
})
observeEvent(input[['SubmitRemoval']], {
if(is.null(values$RowsRemove)) { values$RowsRemove <- as.numeric()}
values$RowsRemove <- unique(c(values$RowsRemove, input[["metadataTable_rows_selected"]]))
})
observeEvent(input[["UndoRemoval"]], {
values$RowsRemove <- NULL
values$Datafiles_meta_Selected <- values$Datafiles_meta
})
}
shinyApp(ui, server)
The num you are using in your javascript to select rows to gray out is based on the row number on the current display so not impacted by sorting.
You could try replacing your if statement in your rowCallbackMeta function by:
if(data[0].search('remove') > -1)
This looks for "remove" in the first column of the data to exclude rows, and works because your glyphicon in the first column is updated to <i class="glyphicon glyphicon-remove"></i> when you exclude rows.

Resources