问题：只要用户位于数据表的不同页面并更新某个列值(通过selectInput),R Shiny Data Table就会重新加载到第一页.
嗨堆栈用户,
在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函数编写代码,用户可以实时更新单元格(通过下拉列表),而不会将表重新加载回第一页？
我已经尝试在这里和互联网上搜索了好几天,但直到现在还没有运气.任何线索将不胜感激.谢谢！
米克洛什
最佳答案 根据您的示例检查下面编辑和评论的代码.我将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)
希望这可以帮助.
