R -shiny- DT：如何更新 col 过滤器

Question

I would like to use DT to allow the users to modify a dataset. However, when the factor cols change (by adding or removing a factor level) the corresponding table filter remains unchanged. In the following example: if I change a Species, the new Species does not appear in the filter dropdown list. Is there a workaround? Many thanks!

library(shiny)
library(DT)

library(dplyr)

iris2=iris %>% group_by(Species)  %>% filter(Petal.Length==max(Petal.Length))

  

ui <- fluidPage(
  fluidRow(column(12, DTOutput("table"))
  )
)

server <- function(input, output, session) {
  output$table <- renderDT({
    
    DT::datatable(iris2, filter = "top", editable=T)
  })
}

shinyApp(ui, server)

Answer 1

You have to feed the changes back into the DT data to get the filters to update. I did this by creating a changeable reactiveVal that DT reads. The next step is to watch for changes to your table and push those changes to the reactiveVal. It's a bit trickier for a factor because you may have to add a new factor level to the column. Another catch is that the edited value may not conform to the original class, so you can force it to match.

library(shiny)
library(DT)
library(dplyr)

iris2=iris %>% group_by(Species)  %>% filter(Petal.Length==max(Petal.Length))

ui <- fluidPage(
  fluidRow(column(12, DTOutput("table")))
)

server <- function(input, output, session) {
  
  iris_rv <- reactiveVal(iris2)         # keep live iris2 table in this reactiveVal
  
  output$table <- renderDT({
    DT::datatable(iris_rv(), filter = "top", editable=T)
  })
  
  observeEvent(input$table_cell_edit, { # watch for edits
    req(input$table_cell_edit)
    
    iris_tmp <- iris_rv()               # transfer to simple variable for easier access
    old_val <- iris_tmp[input$table_cell_edit$row,input$table_cell_edit$col] %>% unlist()
    new_val <- input$table_cell_edit$value
    
    if (class(old_val) == "factor") {   # deal with new factor levels
      old_col <- iris_tmp %>% pull(input$table_cell_edit$col)
      new_col <- factor(old_col, levels = union(levels(old_col), new_val))
      iris_tmp[,input$table_cell_edit$col] <- new_col
    } else {                            # otherwise simply force new value to correct class
      class(new_val) <- class(old_val)
    }
    
    iris_tmp[input$table_cell_edit$row,input$table_cell_edit$col] <- new_val
    iris_rv(iris_tmp)                   # overwrite iris_rv with updated values
  })
}

shinyApp(ui, server)

Answer 2

Using reactiveValues to get the DT to update on change and I used validate to make sure that numbers are correctly provided, clean is where the magic happens, it checks if the column is a factor if so check if the value is a level then if not add it.

library(DT)

iris2 = iris %>% group_by(Species)  %>% filter(Petal.Length==max(Petal.Length))
# get the classes of the columns
types <- sapply(iris2, class)

ui <- fluidPage(
  fluidRow(column(12, DTOutput("table"))
  )
)
types <- sapply(iris2, class)
server <- function(input, output, session) {
  proxy <- DT::dataTableProxy('table')
  RV <- reactiveValues(data = iris2)

  output$table = DT::renderDT({
    RV$data
  }, filter = "top", editable=T)

  observeEvent(input$table_cell_edit, {
    validate(
      need(check_coercibility(input$table_cell_edit$value, types[input$table_cell_edit$col]), "Please enter valid data")
    )
    RV$data <- clean(RV$data, input$table_cell_edit$value, input$table_cell_edit$row, input$table_cell_edit$col)
  }, ignoreInit = TRUE)

}
check_coercibility <- function(x, type){
    if(type == "numeric") {
        suppressWarnings(!is.na(as.numeric(x)))
    } else T
}
clean <- function(df, x, nrow, ncol, type=types[[ncol]]){
    col <- df[[ncol]]
    df[nrow, ncol] <- if(type=="factor"){
        if(! x %in% levels(col)) df[[ncol]] <- factor( col, levels=c(levels(col), x))
        x
    } else if(type=="numeric"){
        as.numeric(x)
    } else if(type=="logical"){
        as.logical(x)
    } else x
    df
}
shinyApp(ui, server)