5

问题：只要用户在数据表的不同页面上并更新某个列值（通过 selectInput），R Shiny 数据表就会重新加载到第一页。

嗨堆栈用户，

在 R Shiny 中，我创建了一个 Shiny 应用程序，其中包含一个数据表 (renderDataTable)，其中列“状态”的单元格值可以由其预期用户更新（通过 selectInput）。

我准备了以下代码的简化示例。

用户界面

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

服务器.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 函数编写代码，用户可以实时更新单元格（通过下拉列表），而无需将表格重新加载回第一页？

我已经尝试在这里和互联网搜索了好几天，但直到现在还没有运气。任何线索将不胜感激。谢谢！

米克洛斯

4

1 回答 1

1

检查下面根据您的示例编辑和评论的代码。我合并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)

希望这可以帮助。

于 2018-11-19T17:29:49.870 回答