Add format to datatable conflicts with action buttons in R shiny - r

I have used the directions in this other question to create a datatable with buttons inside.
I added some formatting to the renderTable() call to highlight in yellow motivation == 3
output$data <- DT::renderDataTable(
datatable(df$data) %>% formatStyle(
'Motivation',
target = 'row',
backgroundColor = styleEqual(c(3), c('yellow'))
),
server = FALSE, escape = FALSE, selection = 'none'
)
This highlights the correct row:
The problem is that color formatting messes up with the buttons. I find the same problem when trying to format dates (datatable automatically shows them in UTC and I want them on local time). Are both formatting and buttons inside the table incompatible?
I get the following warning
renderDataTable ignores ... arguments when expr yields a datatable object; see ?renderDataTable
Here's the code for the app:
library(shiny)
library(DT)
shinyApp(
ui <- fluidPage(
DT::dataTableOutput("data"),
textOutput('myText')
),
server <- function(input, output) {
myValue <- reactiveValues(employee = '')
shinyInput <- function(FUN, len, id, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))
}
inputs
}
df <- reactiveValues(data = data.frame(
Name = c('Dilbert', 'Alice', 'Wally', 'Ashok', 'Dogbert'),
Motivation = c(62, 73, 3, 99, 52),
Actions = shinyInput(actionButton, 5, 'button_', label = "Fire", onclick = 'Shiny.onInputChange(\"select_button\", this.id)' ),
stringsAsFactors = FALSE,
row.names = 1:5
))
output$data <- DT::renderDataTable(
datatable(df$data) %>% formatStyle(
'Motivation',
target = 'row',
backgroundColor = styleEqual(c(3), c('yellow'))
),
server = FALSE, escape = FALSE, selection = 'none'
)
observeEvent(input$select_button, {
selectedRow <- as.numeric(strsplit(input$select_button, "_")[[1]][2])
myValue$employee <<- paste('click on ',df$data[selectedRow,1])
})
output$myText <- renderText({
myValue$employee
})
}
)

You should look at this answer. Applying his advice to your problem, I move escape = FALSE, selection = 'none' in datatable(df$data) and it works (you need to remove server = FALSE, which is not accepted in datatable):
output$data <- DT::renderDataTable(
datatable(df$data, escape = FALSE, selection = 'none') %>% formatStyle(
'Motivation',
target = 'row',
backgroundColor = styleEqual(c(3), c('yellow'))
)
)
In case the answer I refer above is deleted (don't know if it can be), I also put it here:
You are getting this error because you are returning a DT::datatable AND you are also specifying filter='top' as one of the ... arguments to DT::renderDataTable. As the message is trying to tell you ... arguments are ignored since you are returning a DT::datatable. This is because the ... arguments are intended to be passed through to the DT:datatable constructor.
Either move filter='top' inside the DT::datatable constructor or return a data.frame and the filter='top will be used when DT::renderDataTable constructs a DT::datatable with your specified data.frame.

Related

How to reset selected rows in Shiny

I have a small rshiny app, in which i can select row in datatable and get values from first columns.
but how to quickly get rid of the selected rows and values without clicking on the row again?
also if you know what can be improved in this code, then write, I just started coding in R
# Define UI
ui <- fluidPage(
dataTableOutput('main_information'),
fluidRow(
column(8,verbatimTextOutput('selected_rows', placeholder = TRUE)),
fluidRow(
column(4,actionButton("reset", "RESET"))
)
)
)
# Define server function
server <- function(input, output,session) {
getScoreTable<-reactive({
db <- dbConnect(SQLite(), "path")
data <- dbGetQuery(
conn = db,
statement =
'...'
)
})
output$main_information <- renderDataTable(
getScoreTable(),
options = list(
pageLength = 5,
lengthMenu = list(c(5,10, 25, 50, 100),
c('5', '10', '25','50', '100'))
)
)
s<-reactiveValues(data= NULL)
output$selected_rows = renderPrint({
s = input$main_information_rows_selected
if (length(s)) {
cat('These values were selected:\n\n')
cat(getScoreTable()[s,1], sep = '\n')
}else{
cat('No value has been selected')
}
})
}
# Create Shiny object
shinyApp(ui = ui, server = server)
You can use a custom action button:
library(DT)
js <- "
function ( e, dt, node, config ) {
dt.rows().deselect();
}
"
datatable(
iris,
extensions = c("Buttons", "Select"),
selection = "none",
options = list(
"dom" = "Bfrtip",
"select" = TRUE,
"buttons" = list(
list(
"extend" = "collection",
"text" = "DESELECT",
"action" = JS(js)
)
)
)
)
This example works fine. If you have an issue in Shiny, please provide a minimal reproducible code, not using SQL.

R Shiny dataTableOutput - prevent column from showing full text column

I have code to present a table in my R Shiny application. There is a character column where the value within a given cell can be a large number of characters. I use the following code to create the table:
output$data_table <- DT::renderDataTable({
req(data_go_go())
data_go_go()
},rownames = FALSE,filter = "top")
Then display the table with:
DT::dataTableOutput("data_table")
This code results in the following table:
You can see the string in the last column is causing the table to extend very far to the right. Is there a way I can prevent the column from displaying the entire string, and let it display the whole text if you hover over the particular cell?
Here is one option, borrowed heavily from this SO answer written by Stéphane Laurent (R shiny DT hover shows detailed table)
library(shiny)
library(DT)
g = data.frame(
TermID = c("GO:0099536", "GO:0009537", "GO:0007268"),
TermLabel = rep("synaptic signaling",times=3),
Reference= c(907,878,869),
Genes=c(78,74,72),
FoldEnrichment=c(13.69,17.11,14.22),
AdjPValue = c(0,0,0),
`Gene Info` = "Gene Information",
GenesDetail= replicate(paste0(sample(c(" ", letters),100,replace=TRUE), collapse=""),n=3)
)
callback <- c(
"table.on('mouseover', 'td', function(){",
" var index = table.cell(this).index();",
" Shiny.setInputValue('cell', index, {priority: 'event'});",
"});"
)
ui <- fluidPage(DTOutput("geneTable"))
server <- function(input, output, session){
output[["geneTable"]] <- renderDT({
datatable(g[,1:7],callback = JS(callback))
})
filteredData <- eventReactive(input[["cell"]], {
if(input[["cell"]]$column == 7){
return(g[input[["cell"]]$row + 1, "GenesDetail", drop = FALSE])
}
})
output[["tblfiltered"]] <- renderDT({
datatable(filteredData(),fillContainer = TRUE, options=list(dom='t'),rownames = F)
})
observeEvent(filteredData(), {
showModal(modalDialog(
DTOutput("tblfiltered"), size = "l",easyClose = TRUE)
)
})
}
shinyApp(ui, server)
The easiest way is to use the ellipsis plugin:
library(DT)
dat <- data.frame(
A = c("fnufnufroufrcnoonfrncacfnouafc", "fanunfrpn frnpncfrurnucfrnupfenc"),
B = c("DZDOPCDNAL DKODKPODPOKKPODZKPO", "AZERTYUIOPQSDFGHJKLMWXCVBN")
)
datatable(
dat,
plugins = "ellipsis",
options = list(
columnDefs = list(list(
targets = c(1,2),
render = JS("$.fn.dataTable.render.ellipsis( 17, false )")
))
)
)

Unable to print updated values in Reactive inputs using Shiny

We have a situation where in we would want to take inputs from user in a datatable by creating dynamic drop-downs and would want to save the data locally. We have tried multiple combinations however these are not getting working in our scenario for e.g.: reset, refresh (can't use it as we have a login page). Below is the reproducible e.g.:
The problem with the code is that it takes old value not the updated one.
library(shiny)
library(DT)
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("sel", i),
"",
choices = unique(iris$Species),
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)
One solution could be creating dynamic ID's, however this can create complexity in our model as we have multiple drop-downs :
https://community.rstudio.com/t/update-dt-table-dropdowns-with-reactive-data-in-shiny/96100/2
You can execute JavaScript to periodically update selected values of dropdown menus:
e.g. JavaScript e.g. invoked by function shinyjs::runjs
document.getElementById("sel1").value = "versicolor"

Update reactiveValues in Shiny R

I understand similar questions have been asked and I've tried virtually every solution with no luck.
In my application, I've allowed the user to modify individual cells of a DT::datatable. The source of the datatable is a reactive data frame.
After the user makes changes to the clientside datatable, the datatable source is remains unchanged. This is an issue as later on, when I allow the user to add rows to the data table, the row is added onto the source datatable where the clientside datatable then reflects this change. However, this means that if the user makes a change to a cell in the clientside datatable, when the user adds a row to the same table, the change made by the user will be forgotten as it was never made to the source.
I've tried many ways to update the underlying/serverside datatable with no luck. editData keeps giving me errors/NA. I also have tried indexing the serverside table and placing the changed value inside of it, with no luck. I'll post my code below with some comments for specifics..
library(shiny)
library(DT)
library(data.table)
source('~/camo/camo/R/settings.R')
source('~/camo/camo/etl.R')
# Define UI ----
ui <- fluidPage(
titlePanel("PAlpha"),
mainPanel(
fluidRow(
tabsetPanel(id = 'tpanel',
type = "tabs",
tabPanel("Alpha", plotOutput("plot1")),
tabPanel("Beta", plotOutput("plot2")),
tabPanel("Charlie", plotOutput("plot3")),
tabPanel("Delta", plotOutput("plot4")))
),
fluidRow(
splitLayout(
dateInput("sdate", "Start Date"),
dateInput("edate", "End Date"),
textInput("gmin", "Global Minimum"),
textInput("gmax", "Global Maximum")
)
),
fluidRow(
splitLayout(
textInput("groupInp", NULL, placeholder = "New Group"),
actionButton("addGrpBtn", "Add Group"),
textInput("tickerInp", NULL, placeholder = "New Ticker"),
actionButton("addTickerBtn", "Add Ticker")
)
),
fluidRow(
splitLayout(
DT::dataTableOutput('groupsTable'),
DT::dataTableOutput('groupTickers')
),
verbatimTextOutput("print")
)
)
)
# Define server logic ----
server <- function(input, output) {
port_proxy <- dataTableProxy('groupsTable')
rv <- reactiveValues(
portfolio = data.frame('Group' = c('Portfolio'), 'Minimum Weight' = c(0), 'Maximum Weight' = c(0), 'Type' = c('-')),
groups = list(group1 = data.frame('Group' = c('Ticker'), 'Minimum Weight' = c(0), 'Maximum Weight' = c(0), 'Type' = c('-'))),
deletedRows = NULL,
deletedRowIndices = list()
)
output$groupsTable <- DT::renderDataTable(
# Add the delete button column
deleteButtonColumn(rv$portfolio, 'delete_button')
)
output$print <- renderPrint({
rv$portfolio
})
############## LISTENERS ################
observeEvent(input$deletePressed, {
rowNum <- parseDeleteEvent(input$deletePressed)
dataRow <- rv$portfolio[rowNum,]
# Put the deleted row into a data frame so we can undo
# Last item deleted is in position 1
rv$deletedRows <- rbind(dataRow, rv$deletedRows)
rv$deletedRowIndices <- append(rv$deletedRowIndices, rowNum, after = 0)
# Delete the row from the data frame
rv$portfolio <- rv$portfolio[-rowNum,]
})
observeEvent(input$addGrpBtn, {
row <- data.frame('Group' = c(input$groupInp),
'Minimum Weight' = c(0),
'Maximum Weight' = c(0),
'Type' = c('-'))
rv$portfolio <- addRowAt(rv$portfolio, row, nrow(rv$portfolio))
})
observeEvent(input$groupsTable_cell_edit,{
info <- str(input$groupsTable_cell_edit)
i <- info$row
j <- info$col
v <- info$value
rv$portfolio <- editData(rv$portfolio, input$groupsTable_cell_edit) # doesn't work see below
# Warning in DT::coerceValue(v, data[i, j, drop = TRUE]) :
# New value(s) "test" not in the original factor levels: "Portfolio"; will be coerced to NA.
# rv$portfolio[i,j] <- input$groupsTable_cell_edit$value
# rv$portfolio[i,j] <- v #doesn't work
})
}
addRowAt <- function(df, row, i) {
# Slow but easy to understand
if (i > 1) {
rbind(df[1:(i - 1), ], row, df[-(1:(i - 1)), ])
} else {
rbind(row, df)
}
}
deleteButtonColumn <- function(df, id, ...) {
# function to create one action button as string
f <- function(i) {
# https://shiny.rstudio.com/articles/communicating-with-js.html
as.character(actionLink(paste(id, i, sep="_"), label = 'Delete', icon = icon('trash'),
onclick = 'Shiny.setInputValue(\"deletePressed\", this.id, {priority: "event"})'))
}
deleteCol <- unlist(lapply(seq_len(nrow(df)), f))
# Return a data table
DT::datatable(cbind(' ' = deleteCol, df),
# Need to disable escaping for html as string to work
escape = FALSE,
editable = 'cell',
selection = 'single',
rownames = FALSE,
class = 'compact',
options = list(
# Disable sorting for the delete column
dom = 't',
columnDefs = list(list(targets = 1, sortable = FALSE))
))
}
parseDeleteEvent <- function(idstr) {
res <- as.integer(sub(".*_([0-9]+)", "\\1", idstr))
if (! is.na(res)) res
}
# Run the app ----
shinyApp(ui = ui, server = server)
As far as I have looked, there is no ready-to-go solution available. You could try to use rhandsontable. It does not provide all the functionality of the DT table, however it allows for the editing. Last time I tried using it there were some minor issues in some edge cases. (Trying to save different data type or something similar.)
Alternatively you can do the stuff manually, along these lines. This is the minimal working example of editing the underlying data frame. Currently I overwrite it every time the user clicks on the table, you would need to change that to handle normal user behavior. It is meant merely as a proof of concept.
library(DT)
library(shiny)
ui <- fluidPage(
DT::dataTableOutput("test")
)
myDF <- iris[1:10,]
js <- c("table.on('click.dt','tr', function() {",
" var a = table.data();",
" var data = []",
" for (i=0; i!=a.length; i++) {",
" data = data.concat(a[i]) ",
" };",
"Shiny.setInputValue('dataChange', data)",
"})")
server <- function(input, output) {
output$test <- DT::renderDataTable(
myDF,
editable='cell',
callback=JS(js)
)
observeEvent(input$dataChange, {
res <- cbind.data.frame(split(input$dataChange, rep(1:6, times=length(input$dataChange)/6)),
stringsAsFactors=F)
colNumbers <- res[,1]
res <- res[,2:ncol(res)]
colnames(res) <- colnames(myDF)
myDF <<- res
print(myDF)
})
}
shinyApp(ui = ui, server = server)

Use backgroundColor in DT package to change a complete row instead of a single value

The answer is probably obvious but i've been looking into using the backgroundColor attribute in the DT package to change the color of the full row instead of only the value that i use to select the row and I didn't manage to do it.
So basically in my Shiny app, I have a DataTable output in my server file where i wrote this :
output$tableMO <- DT::renderDataTable({
datatable(DFSurvieMO,
options =
list( displayStart= numerMO()-2,
pageLength = 15,
lengthChange = FALSE, searching =FALSE),rownames= FALSE) %>% formatStyle(
c(1:2),
backgroundColor =
if(numerMO()>1) {
styleInterval(c(DFSurvieMO[,1][numerMO()-1],DFSurvieMO[,1][numerMO()]), c('blank','lightblue', 'blank'))
}
else {
styleInterval(DFSurvieMO[,1][numerMO()], c('lightblue', 'blank'))}
)
})
And what i get in my app is a DataTable with only a single cell colored. I tried using target = 'row' but either I didn't put it in the right place or it does not work. So how can i get it to color the whole row ?
Thank You.
You can write some custom JS function using rowCallback. Below I have written a reactive which will listen to the slider and if the slider values in the mtcars dataset are bigger than your value it will repaint the row. Note that the aData[1] is the column called cyl within the mtcars dataset.
Apologies for not using your code as I wanted to make a more generic example
rm(list = ls())
library(shiny)
library(DT)
ui <- basicPage(
sliderInput("trigger", "Trigger",min = 0, max = 10, value = 6, step= 1),
mainPanel(DT::dataTableOutput('my_table'))
)
server <- function(input, output,session) {
my_callback <- reactive({
my_callback <- 'function(nRow, aData, iDisplayIndex, iDisplayIndexFull) {if (parseFloat(aData[1]) >= TRIGGER)$("td", nRow).css("background-color", "#9BF59B");}'
my_callback <- sub("TRIGGER",input$trigger,my_callback)
my_callback
})
output$my_table = DT::renderDataTable(
datatable(mtcars,options = list(
rowCallback = JS(my_callback()),searching = FALSE,paging = FALSE),rownames = FALSE)
)
}
runApp(list(ui = ui, server = server))

Resources