使用下拉选择框编辑Shiny中的数据表格，适用于因子变量。

Question

使用下拉选择框编辑Shiny中的数据表格，适用于因子变量。

13

我正在尝试创建一个Shiny应用程序，允许用户编辑数据表，并保存所做的更改。以下是一个最简示例：

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。

- dwhdai

你能找到一个解决方案吗？ - Dhiraj

1

很遗憾，@Dhiraj，并没有这样做。我使用了reactiveValues和selectInput的组合来实现我的目标，但这并不是一个流动式的设计。 - dwhdai

你应该看看来自Jiena McLellan的此应用程序。 - Alessio

@alessio 谢谢分享。这与我目前的解决方法类似，但不幸的是并不能做到我最初想要的。我想要的是在datatable中使用下拉菜单直接更改因子变量的选项。 - dwhdai

2

你可以使用JS库cellEdit来实现这一点。请参阅此处。 - Stéphane Laurent

1

未来读者：您可以在这里和这里找到使用shiny/DT的相关答案。 - ismirsehregal

1个回答

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- Stéphane Laurent · Accepted Answer

正如我在评论中所说，你可以使用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())，或者干脆不设置此选项。