R Shiny: Editing DT with locked columns

问题:

I am trying to have a DT that is editable by the user but I only want certain columns to be editable. Since this isn't a feature yet in DT, I am trying to hack it together by having the table refresh back to the original value when edited a column that I want "locked".

Below is my code:

library (shiny)
library (shinydashboard)
library (DT)
library (dplyr)
library (data.table)

rm(list=ls())

###########################/ui.R/##################################

#Header----
header <- dashboardHeaderPlus()

#Left Sidebar----
sidebar <- dashboardSidebar()

#Body----
body <- dashboardBody(
  useShinyjs(),

  box(
    title = "Editable Table",
    DT::dataTableOutput("TB")
  ),
  box(
    title = "Backend Table",
    DT::dataTableOutput("Test")
  ),
  box(
    title = "Choice Selection",
    DT::dataTableOutput("Test2")
  ),
  box(
    verbatimTextOutput("text1"),
    verbatimTextOutput("text2"),
    verbatimTextOutput("text3")
  )
)



#Builds Dashboard Page----
ui <- dashboardPage(header, sidebar, body)


###########################/server.R/###############################
server <- function(input, output, session) {


  Hierarchy <- data.frame(Lvl0 = c("US","US","US","US","US"), Lvl1 = c("West","West","East","South","North"), Lvl2 = c("San Fran","Phoenix","Charlotte","Houston","Chicago"), stringsAsFactors = FALSE)

  ###########

  rvs <- reactiveValues(
    data = NA, #dynamic data object
    dbdata = NA, #what's in database
    editedInfo = NA #edited cell information
  )

  observe({
    rvs$data <- Hierarchy
    rvs$dbdata <- Hierarchy
  })

  output$TB <- DT::renderDataTable({

    DT::datatable(
      rvs$data,
      rownames = FALSE,
      editable = TRUE,
      extensions = c('Buttons','Responsive'),
      options = list(
        dom = 't',
        buttons = list(list(
          extend = 'collection',
          buttons = list(list(extend='copy'),
                         list(extend='excel',
                              filename = "Site Specifics Export"),
                         list(extend='print')
          ),
          text = 'Download'
        ))
      )
    ) %>% # Style cells with max_val vector
      formatStyle(
        columns = c("Lvl0","Lvl1"),
        color = "#999999"
      )
  })

  observeEvent(input$TB_cell_edit, {
    info = input$TB_cell_edit

    i = info$row
    j = info$col + 1
    v = info$value

    #Editing only the columns picked
    if(j == 3){
      rvs$data[i, j] <<- DT::coerceValue(v, rvs$data[i, j]) #GOOD

      #Table to determine what has changed
      if (all(is.na(rvs$editedInfo))) { #GOOD
        rvs$editedInfo <- data.frame(row = i, col = j, value = v) #GOOD
      } else { #GOOD
        rvs$editedInfo <- dplyr::bind_rows(rvs$editedInfo, data.frame(row = i, col = j, value = v)) #GOOD
        rvs$editedInfo <- rvs$editedInfo[!(duplicated(rvs$editedInfo[c("row","col")], fromLast = TRUE)), ] #FOOD
      }
    } else {
      if (all(is.na(rvs$editedInfo))) {
        v <-  Hierarchy[i, j]
        rvs$data[i, j] <<- DT::coerceValue(v, rvs$data[i, j])
      } else {
        rvs$data[as.matrix(rvs$editedInfo[1:2])] <- rvs$editedInfo$value
      }
    }
  })

  output$Test <- DT::renderDataTable({
    rvs$data
  }, server = FALSE,
  rownames = FALSE,
  extensions = c('Buttons','Responsive'),
  options = list(
    dom = 't',
    buttons = list(list(
      extend = 'collection',
      buttons = list(list(extend='copy'),
                     list(extend='excel',
                          filename = "Site Specifics Export"),
                     list(extend='print')
      ),
      text = 'Download'
    ))
  )
  )

  output$Test2 <- DT::renderDataTable({
    rvs$editedInfo
  }, server = FALSE,
  rownames = FALSE,
  extensions = c('Buttons','Responsive'),
  options = list(
    dom = 't',
    buttons = list(list(
      extend = 'collection',
      buttons = list(list(extend='copy'),
                     list(extend='excel',
                          filename = "Site Specifics Export"),
                     list(extend='print')
      ),
      text = 'Download'
    ))
  )
  )

  output$text1 <- renderText({input$TB_cell_edit$row})
  output$text2 <- renderText({input$TB_cell_edit$col + 1})
  output$text3 <- renderText({input$TB_cell_edit$value})


}

#Combines Dasboard and Data together----
shinyApp(ui, server)

Everything works as expected except within the observeEvent where I try to refresh the DT if they edited the wrong column:

      if (all(is.na(rvs$editedInfo))) {
        v <-  Hierarchy[i, j]
        rvs$data[i, j] <<- DT::coerceValue(v, rvs$data[i, j])
      } else {
        rvs$data[as.matrix(rvs$editedInfo[1:2])] <- rvs$editedInfo$value
      }

I can't seem to get the DT to coerce back to the original values (the if). Also, when a user has changed values in the correct column and changes something in the wrong column, it doesn't reset the original value (wrong column) while keeping the values changed (corrected column) (the else)

EDIT

I have tried the following and it coerces as expected to "TEST". I have looked at the class of both v = info$value and v <- Hierarchy[i,j] and they are both character and produce the value that I expect. Cannot figure out why it won't coerce to v <- Hierarchy[i,j].

  if (all(is.na(rvs$editedInfo))) {
    v <-  Hierarchy[i, j]
    v <- "TEST"
    rvs$data[i, j] <<- DT::coerceValue(v, rvs$data[i, j])
  } 

回答1:

I have added this feature to the development version of DT.

remotes::install_github('rstudio/DT')

You can find an example in the Table 10 of the Shiny app at https://yihui.shinyapps.io/DT-edit/.