PROBLEM: R Shiny Data Table reloads to the first page whenever user is on a different page of the data table and updates a certain column value (via selectInput).
Hi Stack Users,
In R Shiny, I've created a Shiny application that contains a data table (renderDataTable) where a cell value of column "status" can be updated (via selectInput) by its intended users.
I've prepared a simplified sample of the code below.
ui.R
require(shiny)
require(shinyjs)
require(data.table)
require(dplyr)
require(DT)
shinyUI(fluidPage(
useShinyjs(),
mainPanel("",
fluidRow(
splitLayout(div(DT::dataTableOutput('my_table')),
div(
shinyjs::hidden(
wellPanel(id="my_panel",
h3("Update Status",align="center"),
htmlOutput("my_status")
)
)
)
)
)
)
))
server.R
#### DATA PREP AND FUNCTIONS ######################
id <- c('10001','10002','10003','10004','10005',
'10006','10007','10008','10009','10010',
'10011','10012','10013','10014','10015')
status <- c('OPEN','OPEN','CLOSED','CLOSED','OPEN',
'OPEN','CLOSED','CLOSED','OPEN','CLOSED',
'CLOSED','OPEN','OPEN','OPEN','CLOSED')
dt <- data.table(id=id,status=status)
render_my_table <- function(dt, sel) {
if(missing(sel)) {
sel = list(mode='single')
} else {
sel = list(mode='single', selected = sel)
}
return (DT::datatable(dt[, list("ID" = id, "Status"=status)],
selection = sel, filter="top",
options = list(sDom = '<"top">lrt<"bottom">ip',
lengthChange = FALSE,
pageLength = 5)))
}
change_status <- function(s_id, s, user, new_dt) {
if(!(s %in% c('OPEN','CLOSED'))) {
return (new_dt)
}
new_dt[id == s_id, status :=s]
return (new_dt)
}
#### SERVER ###############################
function(input, output, session) {
output$my_table = DT::renderDataTable({
render_my_table(dt)
}, server=TRUE)
observeEvent(input$my_table_cell_clicked, {
row = as.numeric(input$my_table_rows_selected)
user = dt[row]
if(nrow(user) == 0) {
return ()
}
session$userData$curr_case <- user$id
session$userData$curr_row <- row
output$my_status <- renderUI({
selectInput("my_status", "", c('OPEN','CLOSED'), selected=user$status)
})
shinyjs::showElement(id= "my_panel")
})
observeEvent(input$my_status, {
if(isTRUE(session$userData$curr_case != "")) {
new_dt = dt
current_status = new_dt[id == session$userData$curr_case]$status
new_status = input$my_status
if(current_status != new_status) {
new_dt = change_status(session$userData$curr_case, new_status, new_dt)
output$my_table = DT::renderDataTable({
render_my_table(new_dt, session$userData$curr_row)
})
}
}
})
}
Basically, once a user selects a row from the table, a hidden panel pops up to the right of the table. This shows a drop down list (selectInput) containing a two choices so that the user can update the value of column status (open to close and vice versa) of the selected row.
Right now, the code works as intended. However, it has a bug that annoys the users of the tool. Once a user is on a page, other than page 1, of the data table (e.g. page 2,... to page n) and he/she has updated the status of a row, the change happens but the data table reloads at the first page.
So going back to my problem statement, is there any way I can write the code using R Shiny functions where the user can update the cell real-time (via the drop down list) without the table reloading back to the first page?
I've tried searching here and the internet for days, but until now no luck. Any leads would be appreciated. Thanks!
Miklos
Check the code below edited and commented based on your example. I combined ui and server into one script.
The main idea is to add a callback function in render_my_table to refresh the DT object to the correct page index when it is rendered.
require(shiny)
require(shinydashboard)
require(shinyjs)
require(data.table)
require(dplyr)
require(DT)
require(htmltools)
ui <- shinyUI(fluidPage(
useShinyjs(),
mainPanel("",
fluidRow(
splitLayout(#cellWidths = c("110%", "40%"),
div(DT::dataTableOutput('my_table')),
div(
shinyjs::hidden(
wellPanel(id="my_panel",
h3("Update Status",align="center"),
htmlOutput("my_status")
)
)
)
)
)
)
))
#### DATA PREP AND FUNCTIONS ######################
id <- c('10001','10002','10003','10004','10005',
'10006','10007','10008','10009','10010',
'10011','10012','10013','10014','10015')
status <- c('NEW','PENDING','SOLVED','CLOSED','NEW',
'PENDING','SOLVED','CLOSED','NEW','PENDING',
'SOLVED','CLOSED','NEW','PENDING','SOLVED')
owner <- c('Alice','Bob','Carol','Dave','Me',
'Carol','Bob','Dave','Me','Alice',
'Me','Dave','Bob','Alice','Carol')
dt <- data.table(id=id,status=status)
st <- data.table(id=id,status=status,owner=owner)
render_my_table <- function(dt, sel, pgRowLength, curPgInd = 1) {
if(missing(sel)) {
sel = list(mode='single')
} else {
sel = list(mode='single', selected = sel)
}
# Define a javascript function to load a currently selected page
pgLoadJS <- paste0('setTimeout(function() {table.page(', curPgInd - 1,').draw(false);}, 100);')
return (DT::datatable(dt[, list("ID" = id, "Status"=status)],
selection = sel, filter="top",
options = list(sDom = '<"top">lrt<"bottom">ip',
lengthChange = FALSE,
pageLength = pgRowLength
),
callback = JS(pgLoadJS) # Updates the page index when the table renders
)%>%
formatStyle('Status',
target = 'row',
backgroundColor = styleEqual(c('NEW', 'PENDING', 'SOLVED', 'CLOSED'),
c('white', 'yellow', 'dodgerblue', 'green'))
)
)
}
get_user_ses <- function() {
return ("Me")
}
change_status <- function(s_id, s, user, new_dt) {
if(!(s %in% c('NEW', 'PENDING', 'FRAUD', 'SOLVED', 'CLOSED'))) {
return (new_dt)
}
st = st
if(nrow(st[id == s_id]) == 0) {
st = rbind(st, data.table("id" = c(s_id), "status" = c(s), "owner" = c(ifelse(is.null(user), NA, user))))
} else {
st[id == s_id, status:=s]
st[id == s_id, owner:=ifelse(is.null(user), NA, user)]
}
new_dt[id == s_id, status :=s]
new_dt[id == s_id, owner :=user]
return (new_dt)
}
#### SERVER ###############################
# Defines number of rows per page to find the page number of the edited row
defaultPgRows <- 5
server <- function(input, output, session) {
# Saves the row index of the selected row
curRowInd <- reactive({
req(input$my_table_rows_selected)
as.numeric(input$my_table_rows_selected)
})
output$my_table = DT::renderDataTable({
render_my_table(dt,
pgRowLength = defaultPgRows)
}, server=TRUE)
observeEvent(input$my_table_cell_clicked, {
row = curRowInd()
user = dt[row]
if(nrow(user) == 0) {
return ()
}
session$userData$curr_case <- user$id
session$userData$curr_row <- row
output$my_status <- renderUI({
selectInput("my_status", "", c('NEW','PENDING','SOLVED','CLOSED'), selected=user$status)
})
shinyjs::showElement(id= "my_panel")
})
observeEvent(input$my_status, {
if(isTRUE(session$userData$curr_case != "")) {
new_dt = dt
current_status = new_dt[id == session$userData$curr_case]$status
new_status = input$my_status
if(current_status != new_status) {
new_dt = change_status(session$userData$curr_case, new_status, get_user_ses(), new_dt)
# Calculates the page index of the edited row
curPageInd <- ceiling(curRowInd() / defaultPgRows)
print(curPageInd)
output$my_table = DT::renderDataTable({
render_my_table(new_dt, session$userData$curr_row,
pgRowLength = defaultPgRows,
curPgInd = curPageInd) # Uses the current page index to render a new table
})
}
}
})
}
runApp(list(ui = ui, server = server), launch.browser = TRUE)
Hope this helps.