R - Shiny Data Table (renderDataTable) reloads to first page when user is on a different page and updates a certain column value (selectInput)

Question

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

Jason Jisu Park Jason Jisu Park · Accepted Answer · 2018-11-19T17:29:49

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.

R - Shiny Data Table (renderDataTable) reloads to first page when user is on a different page and updates a certain column value (selectInput)

1 Answers