使用下拉選擇編輯閃亮的數據表（對於 DT v0.19）

Question

我將下面的代碼基於 Stephane Laurent 對 Stack Overflow 上以下問題的解決方案：

我在代碼中添加了使用 editData 來更新表並能夠保存/導出更新。

以下適用於 DT v0.18 但使用 DT v0.19 我發現 id_cell_edit 似乎沒有觸發。 我不確定它是否與回調有關，或者可能與 jquery.contextMenu 有關，因為 DT v0.19 已升級到 jquery 3.0。 希望人們對如何解決這個問題有任何見解。

這是我在使用 v0.18 時觀察到的行為的描述。 當我選擇使用列並將第一行的值從默認的“sel”更新為“id”時，DT 表中的值會發生變化。 我還看到它更新了 tibble 的視圖，因此下載的 csv 文件中的數據也被更新了。 如果我進入下一頁查看第 11 項，然后返回第一頁，我可以看到我更新的記錄仍然顯示“id”。

這是我在使用 v0.19 時觀察到的行為的描述。 當我選擇使用列並將第一行的值從默認的“sel”更新為“id”時，DT 表中的值會發生變化。 它不會更新 tibble 的視圖，因此下載的 csv 文件中的數據不會更新。 如果我進入下一頁查看第 11 項，然后返回第一頁，我所做的更新將被清除。

請注意，我還使用 reactlog 運行反應圖。 我按照相同的步驟將第一行的使用列更新為“id”。 我注意到的第一個區別是，當我使用 v0.18 版本時，第 5 步的 reactiveValues###$dt 給了我一個 7 的列表，而當我使用 v0.19 版本時，我給出了一個 8 的列表。 在第 16 步，對於 v0.18，input$dt_cell_edit 無效，然后 Data 無效並且 output$table 無效。 然而，在使用 v0.19 時的第 16 步，output$dt 無效，然后 output$table 無效。 換句話說，當使用 v0.19 時 input$dt_cell_edit 和 Data 不會失效。

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

cars_df <- mtcars
cars_meta <- dplyr::tibble(variables = names(cars_df), data_class = sapply(cars_df, class), usage = "sel")
cars_meta$data_class <- factor(cars_meta$data_class,  c("numeric", "character", "factor", "logical"))
cars_meta$usage <- factor(cars_meta$usage,  c("id", "meta", "demo", "sel", "text"))


callback <- c(
    "var id = $(table.table().node()).closest('.datatables').attr('id');",
    "$.contextMenu({",
    "  selector: '#' + id + ' td.factor input[type=text]',",
    "  trigger: 'hover',",
    "  build: function($trigger, e){",
    "    var levels = $trigger.parent().data('levels');",
    "    if(levels === undefined){",
    "      var colindex = table.cell($trigger.parent()[0]).index().column;",
    "      levels = table.column(colindex).data().unique();",
    "    }",
    "    var options = levels.reduce(function(result, item, index, array){",
    "      result[index] = item;",
    "      return result;",
    "    }, {});",
    "    return {",
    "      autoHide: true,",
    "      items: {",
    "        dropdown: {",
    "          name: 'Edit',",
    "          type: 'select',",
    "          options: options,",
    "          selected: 0",
    "        }",
    "      },",
    "      events: {",
    "        show: function(opts){",
    "          opts.$trigger.off('blur');",
    "        },",
    "        hide: function(opts){",
    "          var $this = this;",
    "          var data = $.contextMenu.getInputValues(opts, $this.data());",
    "          var $input = opts.$trigger;",
    "          $input.val(options[data.dropdown]);",
    "          $input.trigger('change');",
    "        }",
    "      }",
    "    };",
    "  }",
    "});"
)

createdCell <- function(levels){
    if(missing(levels)){
        return("function(td, cellData, rowData, rowIndex, colIndex){}")
    }
    quotedLevels <- toString(sprintf("\"%s\"", levels))
    c(
        "function(td, cellData, rowData, rowIndex, colIndex){",
        sprintf("  $(td).attr('data-levels', '[%s]');", quotedLevels),
        "}"
    )
}

ui <- fluidPage(
    tags$head(
        tags$link(
            rel = "stylesheet",
            href = "https://cdnjs.cloudflare.com/ajax/libs/jquery-contextmenu/2.8.0/jquery.contextMenu.min.css"
        ),
        tags$script(
            src = "https://cdnjs.cloudflare.com/ajax/libs/jquery-contextmenu/2.8.0/jquery.contextMenu.min.js"
        )
    ),
    DTOutput("dt"),
    br(),
    verbatimTextOutput("table"),
    br(),
    downloadButton('download',"Download the data")
    
)

server <- function(input, output){
    
    dat <- cars_meta
    
    value <- reactiveValues()
    value$dt<-
        datatable(
            dat, editable = "cell", callback = JS(callback),
            options = list(
                columnDefs = list(
                    list(
                        targets = 2,
                        className = "factor",
                        createdCell = JS(createdCell(c(levels(cars_meta$data_class), "another level")))
                    ),
                    list(
                        targets = 3,
                        className = "factor",
                        createdCell = JS(createdCell(c(levels(cars_meta$usage), "another level")))
                    )
                )
            )
        )
    
    output[["dt"]] <- renderDT({
        value$dt
        
    }, 
    server = TRUE)
    
    Data <- reactive({
        info <- input[["dt_cell_edit"]]
        if(!is.null(info)){
            info <- unique(info)
            info$value[info$value==""] <- NA
            dat <-  editData(dat, info, proxy = "dt")
        }
        dat
    })
    
    
    #output table to be able to confirm the table updates
    output[["table"]] <- renderPrint({Data()})  
    
    output$download <- downloadHandler(
        filename = function(){"Data.csv"}, 
        content = function(fname){
            write.csv(Data(), fname)
        }
    )
}

shinyApp(ui, server)

下面我在我的用例中利用了 ismirsehregal 的解決方案。 我還添加了 renderPrint/verbatimTextOutput 來說明我要對基礎數據做什么。 我希望能夠捕獲值而不是輸入容器。 本質上，我試圖給用戶一個數據集的代碼，允許他們更改一些值，但通過下拉菜單限制選擇，然后使用更新的數據集進行進一步處理。 在解決方案的這一點上，我不知道如何獲取更新的數據集，以便我可以使用它，例如，導出到 csv 文件。

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


cars_df <- mtcars
selectInputIDa <- paste0("sela", 1:length(cars_df))
selectInputIDb <- paste0("selb", 1:length(cars_df))

initMeta <- dplyr::tibble(
    variables = names(cars_df), 
    data_class = sapply(selectInputIDa, function(x){as.character(selectInput(inputId = x, label = "", choices = c("character","numeric", "factor", "logical"), selected = sapply(cars_df, class)))}),
    usage = sapply(selectInputIDb, function(x){as.character(selectInput(inputId = x, label = "", choices = c("id", "meta", "demo", "sel", "text"), selected = "sel"))})
)



ui <- fluidPage(
    DT::dataTableOutput(outputId = 'my_table'),
    br(),
    verbatimTextOutput("table")
)


server <- function(input, output, session) {
    
    
    displayTbl <- reactive({
        dplyr::tibble(
            variables = names(cars_df), 
            data_class = sapply(selectInputIDa, function(x){as.character(selectInput(inputId = x, label = "", choices = c("numeric", "character", "factor", "logical"), selected = input[[x]]))}),
            usage = sapply(selectInputIDb, function(x){as.character(selectInput(inputId = x, label = "", choices = c("id", "meta", "demo", "sel", "text"), selected = input[[x]]))})
        )
    })
    
    

    
    output$my_table = DT::renderDataTable({
        DT::datatable(
            initMeta, escape = FALSE, selection = 'none', rownames = FALSE,
            options = list(paging = FALSE, ordering = FALSE, scrollx = TRUE, dom = "t",
                           preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
                           drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
            )
        )
    }, server = TRUE)
    
    my_table_proxy <- dataTableProxy(outputId = "my_table", session = session)
    
    observeEvent({sapply(selectInputIDa, function(x){input[[x]]})}, {
        replaceData(proxy = my_table_proxy, data = displayTbl(), rownames = FALSE) # must repeat rownames = FALSE see ?replaceData and ?dataTableAjax
    }, ignoreInit = TRUE)
    
    observeEvent({sapply(selectInputIDb, function(x){input[[x]]})}, {
        replaceData(proxy = my_table_proxy, data = displayTbl(), rownames = FALSE) # must repeat rownames = FALSE see ?replaceData and ?dataTableAjax
    }, ignoreInit = TRUE)
    
    
    
    output$table <- renderPrint({displayTbl()})  
    
    
}

shinyApp(ui = ui, server = server)

Answer 1

要獲得resultTbl ，您只需訪問input[x]的：

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

cars_df <- mtcars
selectInputIDa <- paste0("sela", 1:length(cars_df))
selectInputIDb <- paste0("selb", 1:length(cars_df))

initMeta <- dplyr::tibble(
  variables = names(cars_df), 
  data_class = sapply(selectInputIDa, function(x){as.character(selectInput(inputId = x, label = "", choices = c("character","numeric", "factor", "logical"), selected = sapply(cars_df, class)))}),
  usage = sapply(selectInputIDb, function(x){as.character(selectInput(inputId = x, label = "", choices = c("id", "meta", "demo", "sel", "text"), selected = "sel"))})
)

ui <- fluidPage(
  DT::dataTableOutput(outputId = 'my_table'),
  br(),
  verbatimTextOutput("table")
)

server <- function(input, output, session) {

  displayTbl <- reactive({
    dplyr::tibble(
      variables = names(cars_df), 
      data_class = sapply(selectInputIDa, function(x){as.character(selectInput(inputId = x, label = "", choices = c("numeric", "character", "factor", "logical"), selected = input[[x]]))}),
      usage = sapply(selectInputIDb, function(x){as.character(selectInput(inputId = x, label = "", choices = c("id", "meta", "demo", "sel", "text"), selected = input[[x]]))})
    )
  })
  
  resultTbl <- reactive({
    dplyr::tibble(
      variables = names(cars_df), 
      data_class = sapply(selectInputIDa, function(x){input[[x]]}),
      usage = sapply(selectInputIDb, function(x){input[[x]]})
    )
  })
  
  output$my_table = DT::renderDataTable({
    DT::datatable(
      initMeta, escape = FALSE, selection = 'none', rownames = FALSE,
      options = list(paging = FALSE, ordering = FALSE, scrollx = TRUE, dom = "t",
                     preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
                     drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
      )
    )
  }, server = TRUE)
  
  my_table_proxy <- dataTableProxy(outputId = "my_table", session = session)
  
  observeEvent({sapply(selectInputIDa, function(x){input[[x]]})}, {
    replaceData(proxy = my_table_proxy, data = displayTbl(), rownames = FALSE) # must repeat rownames = FALSE see ?replaceData and ?dataTableAjax
  }, ignoreInit = TRUE)
  
  observeEvent({sapply(selectInputIDb, function(x){input[[x]]})}, {
    replaceData(proxy = my_table_proxy, data = displayTbl(), rownames = FALSE) # must repeat rownames = FALSE see ?replaceData and ?dataTableAjax
  }, ignoreInit = TRUE)
  
  output$table <- renderPrint({resultTbl()})  
  
}

shinyApp(ui = ui, server = server)

PS：這是基於我之前的回答here 。

使用下拉選擇編輯閃亮的數據表（對於 DT v0.19）

問題描述

1 個解決方案

解決方案1
3 已采納 2021-11-16 14:45:54

使用下拉選擇編輯閃亮的數據表（對於 DT v0.19）

問題描述

1 個解決方案

解決方案1 3 已采納 2021-11-16 14:45:54

解決方案1
3 已采納 2021-11-16 14:45:54