R - Shiny Data Table (renderDataTable) перезагружается на первую страницу, когда пользователь находится на другой странице и обновляет определенное значение столбца (selectInput) - PullRequest
Новая
       15

R - Shiny Data Table (renderDataTable) перезагружается на первую страницу, когда пользователь находится на другой странице и обновляет определенное значение столбца (selectInput)

0 голосов
/ 19 ноября 2018

ПРОБЛЕМА: R Таблица блестящих данных перезагружается на первую страницу, когда пользователь находится на другой странице таблицы данных, и обновляет определенное значение столбца (через selectInput).

Пользователи Hi Stack,

В R Shiny я создал приложение Shiny, которое содержит таблицу данных (renderDataTable), в которой значение ячейки столбца " status " может быть обновлено (через selectInput) предполагаемыми пользователями.

Я подготовил упрощенный пример кода ниже.

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

Обычно, когда пользователь выбирает строку из таблицы, справа от таблицы появляется скрытая панель. Это показывает выпадающий список (selectInput), содержащий два варианта, так что пользователь может обновить значение статуса столбца (открыто для закрытия и наоборот) выбранной строки.

Сейчас код работает как задумано. Однако в нем есть ошибка, которая раздражает пользователей инструмента. Когда пользователь попадает на страницу, отличную от страницы 1, таблицы данных (например, страница 2, ... на страницу n) и обновляет состояние строки, происходит изменение, но таблица данных перезагружается с первая страница

Итак, возвращаясь к моей постановке проблемы, можно ли как-нибудь написать код, используя функции R Shiny, где пользователь может обновлять ячейку в реальном времени (через раскрывающийся список), не перезагружая таблицу обратно на первую страницу?

Я пытался искать здесь и в Интернете в течение нескольких дней, но до сих пор не повезло. Любые выводы будут оценены. Спасибо!

Миклос

1 Ответ

0 голосов
/ 19 ноября 2018

Проверьте код ниже, отредактированный и прокомментированный на основе вашего примера. Я объединил ui и server в один скрипт.

Основная идея заключается в добавлении функции обратного вызова в render_my_table для обновления объекта DT до правильного индекса страницы при его отображении. 

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)

Надеюсь, это поможет.

...