使用因子变量的下拉选择在 Shiny 中编辑数据表

Posted 2023-02-14

【中文标题】使用因子变量的下拉选择在 Shiny 中编辑数据表

【英文标题】：Edit datatable in Shiny with dropdown selection for factor variables

【发布时间】：2019-03-06 16:57:37

【问题描述】：

我正在尝试创建一个闪亮的应用程序，允许用户编辑数据表，从而保存编辑。这是一个最小的例子：

library(shiny)
library(DT)

ui <- fluidPage(
  DT::DTOutput('df')
)

server <- function(session, input, output)
  df <- data.frame(x = factor(c("A", "B", "C"), levels = c("A", "B", "C")))
  output$df <- DT::renderDT(df,
                        editable = T)

  proxy <- dataTableProxy("df")

  observeEvent(input$df_cell_edit, 
    info <- input$df_cell_edit
    str(info)
    i <- info$row
    j <-  info$col
    v <- info$value
    df[i, j] <<- DT:::coerceValue(v, df[i, j])
    replaceData(proxy, df, resetPaging = FALSE)

  )


shinyApp(ui, server)

这允许我在线编辑x 的值，但由于x 是一个因素，我想限制用户能够输入的值。理想情况下，我希望使用下拉菜单完成此操作。使用 DT::datatable 和 Shiny 是否可以实现此功能？

注意：我知道rhandsontable 包，但是如果可能的话我更喜欢使用DT。

【问题讨论】：

你能找到解决办法吗？

@Dhiraj 不幸的是没有。我使用了 reactiveValues 和 selectInput 的组合来获得我想要的，但这不是一个流畅的设计。

你应该看看 Jiena McLellan 的 this app。

您可以使用 JS 库 cellEdit 做到这一点。见here。

对于未来的读者：Here 和 here，您可以使用闪亮/仅 DT 方法找到相关答案。

【参考方案1】：

正如我在评论中所说，您可以使用 JS 库 cellEdit 做到这一点。

这是另一种方式，使用 JS 库 contextMenu（一个 jQuery 插件）。

library(shiny)
library(DT)

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 colindex = table.cell($trigger.parent()[0]).index().column;",
  "    var coldata = table.column(colindex).data().unique();",
  "    var options = coldata.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');",
  "        ",
  "      ",
  "    ;",
  "  ",
  ");" 
)
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("dtable")
)

server <- function(input, output)
  output[["dtable"]] <- renderDT(
    datatable(
      iris, editable = "cell", callback = JS(callback), 
      options = list(
        columnDefs = list(
          list(
            targets = 5, className = "factor"
          )
        )
      )
    )
  , server = FALSE)  


shinyApp(ui, server)

编辑

这是一个改进。在之前的应用程序中，下拉选项设置为列的唯一值。使用下面的应用程序，您可以设置所需的下拉选项。

library(shiny)
library(DT)

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("dtable")
)

server <- function(input, output)
  output[["dtable"]] <- renderDT(
    datatable(
      iris, editable = "cell", callback = JS(callback),
      options = list(
        columnDefs = list(
          list(
            targets = 5,
            className = "factor",
            createdCell = JS(createdCell(c(levels(iris$Species), "another level")))
          )
        )
      )
    )
  , server = FALSE)


shinyApp(ui, server)

如果您想使用列的唯一值，请将选项createdCell 设置为JS(createdCell())，或者干脆不设置此选项。

【讨论】：

这个答案太棒了！！！我只是想知道您是否知道如何使用另一个数据框填充数据表每一列的下拉菜单，该数据框与数据表中使用的数据框共享一些公共列？我想过这样的事情：createdCell = JS(createdCell(c(levels(dataframe2[,input$dtable_columns_selected])))) 但它不起作用！