我在 Shiny 应用程序中的 DataTables 包中遇到了 renderDT 问题。有时,我需要从表中删除一行或多行。虽然有一个有用的行删除示例(https://github.com/stefaneng/Shiny-DeleteRowsDT/blob/master/app.R),我将其用作起点,但我发现当删除一行时,renderDT 会导致应用程序跳回第一页,当有多个页面时,这可能会造成破坏。
我尝试按照这篇post中的建议使用DT::replaceData,但它没有按我的预期工作,可能是因为表尺寸受到了影响。
我使用了下面的解决方案(受此post启发),该解决方案涉及在 renderDT 之后运行 selectPage。然而,该解决方案似乎在 70% 的情况下都有效。知道为什么以及如何改进吗?
library(shiny)
library(DT)
ui <- fluidPage(
titlePanel("Delete rows"),
mainPanel(
selectInput('datasetSelect',
label = 'Select data',
choices = c("mtcars", "iris", "faithful")),
uiOutput('undoUI'),
DT::dataTableOutput("dtable")
)
)
server <- function(input, output) {
rv <- reactiveValues(
data = NULL,
deletedRows = NULL,
deletedRowIndices = list()
)
pageNumber <- reactiveVal(1)
observeEvent(input$datasetSelect, {
rv$data <- switch (input$datasetSelect,
"mtcars" = mtcars,
"iris" = iris,
"faithful" = faithful
)
# Clear the previous deletions
rv$deletedRows <- NULL
rv$deletedRowIndices = list()
})
observeEvent(input$deletePressed, {
rowNum <- parseDeleteEvent(input$deletePressed)
dataRow <- rv$data[rowNum,]
# Put the deleted row into a data frame so we can undo
# Last item deleted is in position 1
rv$deletedRows <- rbind(dataRow, rv$deletedRows)
rv$deletedRowIndices <- append(rv$deletedRowIndices, rowNum, after = 0)
# Delete the row from the data frame
rv$data <- rv$data[-rowNum,, drop = FALSE]
# On last page and removing the only remaining row?
last_element <- input$dtable_row_last_clicked %% input$dtable_state$length == 1
last_page <- input$dtable_row_last_clicked == max(input$dtable_rows_all)
# Add = 1 if the number of page is not affected by the deletion
add <- ifelse(last_element && last_page, 0, 1)
pageNumber(input$dtable_state$start/input$dtable_state$length+add) # set
output$dtable <- DT::renderDT(deleteButtonColumn(isolate(rv$data), 'delete_button'))
})
# Set the page
observeEvent (input$dtable_cell_clicked, {
proxy <- DT::dataTableProxy('dtable')
selectPage(proxy, pageNumber())
})
observeEvent(input$undo, {
if(nrow(rv$deletedRows) > 0) {
row <- rv$deletedRows[1, ]
rv$data <- addRowAt(rv$data, row, rv$deletedRowIndices[[1]])
# Remove row
rv$deletedRows <- rv$deletedRows[-1,]
# Remove index
rv$deletedRowIndices <- rv$deletedRowIndices[-1]
}
})
# Disable the undo button if we have not deleted anything
output$undoUI <- renderUI({
if(!is.null(rv$deletedRows) && nrow(rv$deletedRows) > 0) {
actionButton('undo', label = 'Undo delete', icon('undo'))
} else {
actionButton('undo', label = 'Undo delete', icon('undo'), disabled = TRUE)
}
})
output$dtable <- DT::renderDT(
# Add the delete button column
isolate(deleteButtonColumn(rv$data, 'delete_button'))
)
}
#' Adds a row at a specified index
#'
#' @param df a data frame
#' @param row a row with the same columns as \code{df}
#' @param i the index we want to add row at.
#' @return the data frame with \code{row} added to \code{df} at index \code{i}
addRowAt <- function(df, row, i) {
# Slow but easy to understand
if (i > 1) {
rbind(df[1:(i - 1), ], row, df[-(1:(i - 1)), ])
} else {
rbind(row, df)
}
}
#' A column of delete buttons for each row in the data frame for the first column
#'
#' @param df data frame
#' @param id id prefix to add to each actionButton. The buttons will be id'd as id_INDEX.
#' @return A DT::datatable with escaping turned off that has the delete buttons in the first column and \code{df} in the other
deleteButtonColumn <- function(df, id, ...) {
# function to create one action button as string
f <- function(i) {
# https://shiny.rstudio.com/articles/communicating-with-js.html
as.character(actionButton(paste(id, i, sep="_"), label = NULL, icon = icon('trash'),
onclick = 'Shiny.setInputValue(\"deletePressed\", this.id, {priority: "event"})'))
}
deleteCol <- unlist(lapply(seq_len(nrow(df)), f))
# Return a data table
DT::datatable(cbind(delete = deleteCol, df),
# Need to disable escaping for html as string to work
escape = FALSE,
editable = TRUE,
options = list(pageLength = 5,
# Disable sorting for the delete column
columnDefs = list(list(targets = 1, sortable = FALSE))
))
}
#' Extracts the row id number from the id string
#' @param idstr the id string formated as id_INDEX
#' @return INDEX from the id string id_INDEX
parseDeleteEvent <- function(idstr) {
res <- as.integer(sub(".*_([0-9]+)", "\\1", idstr))
if (! is.na(res)) res
}
# Run the application
shinyApp(ui = ui, server = server)
对观察者事件使用不同的触发器似乎就足够了。
# Set the page
observeEvent (input$dtable_rows_all, {
proxy <- DT::dataTableProxy('dtable')
selectPage(proxy, pageNumber())
})
我对表格进行了多次修改,所以最后我使用了类似于下面代码的内容:
library(shiny)
library(DT)
ui <- fluidPage(
titlePanel("Delete rows"),
mainPanel(
selectInput('datasetSelect',
label = 'Select data',
choices = c("mtcars", "iris", "faithful")),
uiOutput('undoUI'),
DT::dataTableOutput("dtable")
)
)
server <- function(input, output) {
rv <- reactiveValues(
data = NULL,
deletedRows = NULL,
deletedRowIndices = list()
)
pageNumber <- reactiveVal(1)
trigger <- reactiveVal(0)
observeEvent(input$datasetSelect, {
rv$data <- switch (input$datasetSelect,
"mtcars" = mtcars,
"iris" = iris,
"faithful" = faithful
)
# Clear the previous deletions
rv$deletedRows <- NULL
rv$deletedRowIndices = list()
})
observeEvent(input$deletePressed, {
rowNum <- parseDeleteEvent(input$deletePressed)
dataRow <- rv$data[rowNum,]
# Put the deleted row into a data frame so we can undo
# Last item deleted is in position 1
rv$deletedRows <- rbind(dataRow, rv$deletedRows)
rv$deletedRowIndices <- append(rv$deletedRowIndices, rowNum, after = 0)
# Delete the row from the data frame
rv$data <- rv$data[-rowNum,, drop = FALSE]
# On last page and removing the only remaining row?
last_element <- input$dtable_row_last_clicked %% input$dtable_state$length == 1
last_page <- input$dtable_row_last_clicked == max(input$dtable_rows_all)
# Add = 1 if the number of page is not affected by the deletion
add <- ifelse(last_element && last_page, 0, 1) #
pageNumber(input$dtable_state$start/input$dtable_state$length+add) # set
trigger(trigger() + 1)
})
# Set the page
observeEvent (trigger(), {
output$dtable <- DT::renderDT(isolate(deleteButtonColumn(rv$data, 'delete_button')), server = TRUE)
})
# Set the page
observeEvent (input$dtable_rows_all, {
proxy <- DT::dataTableProxy('dtable')
# browser()
# input$dtable_rows_selected
# input$dtable_cells_selected
# input$dtable_rows_all
selectPage(proxy, pageNumber())
})
observeEvent(input$undo, {
if(nrow(rv$deletedRows) > 0) {
row <- rv$deletedRows[1, ]
rv$data <- addRowAt(rv$data, row, rv$deletedRowIndices[[1]])
# Remove row
rv$deletedRows <- rv$deletedRows[-1,]
# Remove index
rv$deletedRowIndices <- rv$deletedRowIndices[-1]
}
})
# Disable the undo button if we have not deleted anything
output$undoUI <- renderUI({
if(!is.null(rv$deletedRows) && nrow(rv$deletedRows) > 0) {
actionButton('undo', label = 'Undo delete', icon('undo'))
} else {
actionButton('undo', label = 'Undo delete', icon('undo'), disabled = TRUE)
}
})
output$dtable <- DT::renderDT(
# Add the delete button column
isolate(deleteButtonColumn(rv$data, 'delete_button'))
)
}
#' Adds a row at a specified index
#'
#' @param df a data frame
#' @param row a row with the same columns as \code{df}
#' @param i the index we want to add row at.
#' @return the data frame with \code{row} added to \code{df} at index \code{i}
addRowAt <- function(df, row, i) {
# Slow but easy to understand
if (i > 1) {
rbind(df[1:(i - 1), ], row, df[-(1:(i - 1)), ])
} else {
rbind(row, df)
}
}
#' A column of delete buttons for each row in the data frame for the first column
#'
#' @param df data frame
#' @param id id prefix to add to each actionButton. The buttons will be id'd as id_INDEX.
#' @return A DT::datatable with escaping turned off that has the delete buttons in the first column and \code{df} in the other
deleteButtonColumn <- function(df, id, ...) {
# function to create one action button as string
f <- function(i) {
# https://shiny.rstudio.com/articles/communicating-with-js.html
as.character(actionButton(paste(id, i, sep="_"), label = NULL, icon = icon('trash'),
onclick = 'Shiny.setInputValue(\"deletePressed\", this.id, {priority: "event"})'))
}
deleteCol <- unlist(lapply(seq_len(nrow(df)), f))
# Return a data table
DT::datatable(cbind(delete = deleteCol, df),
# Need to disable escaping for html as string to work
escape = FALSE,
editable = TRUE,
options = list(pageLength = 5,
# Disable sorting for the delete column
columnDefs = list(list(targets = 1, sortable = FALSE, stateSave = TRUE))
))
}
#' Extracts the row id number from the id string
#' @param idstr the id string formated as id_INDEX
#' @return INDEX from the id string id_INDEX
parseDeleteEvent <- function(idstr) {
res <- as.integer(sub(".*_([0-9]+)", "\\1", idstr))
if (! is.na(res)) res
}
# Run the application
shinyApp(ui = ui, server = server)