更新 Shiny R 中的反应值

Question

我知道有人问过类似的问题，但我几乎尝试了所有解决方案，但都没有成功。

在我的应用程序中，我允许用户修改 DT::datatable 的单个单元格。数据表的来源是一个反应式数据框。 用户对客户端数据表进行更改后，数据表源保持不变。这是稍后的问题，当我允许用户向数据表中添加行时，该行被添加到源数据表中，然后客户端数据表会反映此更改。 但是，这意味着如果用户对客户端数据表中的单元格进行更改，当用户向同一个表中添加一行时，用户所做的更改将被遗忘，因为它从未对源进行过.

我尝试了很多方法来更新底层/服务器端数据表，但都没有成功。 editData 不断给我错误/不适用。我也尝试过索引服务器端表并将更改的值放入其中，但没有运气。我将在下面发布我的代码以及一些具体的 cmets..

library(shiny)
library(DT)
library(data.table)
source('~/camo/camo/R/settings.R')
source('~/camo/camo/etl.R')

# Define UI ----
ui <- fluidPage(
  titlePanel("PAlpha"),
  mainPanel(
    fluidRow(
      tabsetPanel(id = 'tpanel',
                  type = "tabs",
                  tabPanel("Alpha", plotOutput("plot1")),
                  tabPanel("Beta", plotOutput("plot2")),
                  tabPanel("Charlie",  plotOutput("plot3")),
                  tabPanel("Delta", plotOutput("plot4")))
    ),
    fluidRow(
      splitLayout(
        dateInput("sdate", "Start Date"),
        dateInput("edate", "End Date"),
        textInput("gmin", "Global Minimum"),
        textInput("gmax", "Global Maximum") 
      )
    ),
    fluidRow(
      splitLayout(
        textInput("groupInp", NULL, placeholder = "New Group"),
        actionButton("addGrpBtn", "Add Group"),
        textInput("tickerInp", NULL, placeholder = "New Ticker"),
        actionButton("addTickerBtn", "Add Ticker")
      )
    ),
    fluidRow(
      splitLayout(
        DT::dataTableOutput('groupsTable'),
        DT::dataTableOutput('groupTickers')
      ),
      verbatimTextOutput("print")
    )
  )
)

# Define server logic ----
server <- function(input, output) {
  port_proxy <- dataTableProxy('groupsTable')
  rv <- reactiveValues(
    portfolio = data.frame('Group' = c('Portfolio'), 'Minimum Weight' = c(0), 'Maximum Weight' = c(0), 'Type' = c('-')),
    groups = list(group1 = data.frame('Group' = c('Ticker'), 'Minimum Weight' = c(0), 'Maximum Weight' = c(0), 'Type' = c('-'))),
    deletedRows  = NULL, 
    deletedRowIndices = list()
  )
  output$groupsTable <- DT::renderDataTable(
    # Add the delete button column
    deleteButtonColumn(rv$portfolio, 'delete_button')
  )
  output$print <- renderPrint({
    rv$portfolio
  })

  ############## LISTENERS ################

  observeEvent(input$deletePressed, {
    rowNum <- parseDeleteEvent(input$deletePressed)
    dataRow <- rv$portfolio[rowNum,]
    # Put the deleted row into a data frame so we can undo
    # Last item deleted is in position 1
    rv$deletedRows <- rbind(dataRow, rv$deletedRows)
    rv$deletedRowIndices <- append(rv$deletedRowIndices, rowNum, after = 0)

    # Delete the row from the data frame
    rv$portfolio <- rv$portfolio[-rowNum,]
  })

  observeEvent(input$addGrpBtn, {
    row <- data.frame('Group' = c(input$groupInp), 
                      'Minimum Weight' = c(0),
                      'Maximum Weight' = c(0), 
                      'Type' = c('-'))
    rv$portfolio <- addRowAt(rv$portfolio, row, nrow(rv$portfolio))
  })

  observeEvent(input$groupsTable_cell_edit,{
    info <- str(input$groupsTable_cell_edit)
    i <- info$row
    j <- info$col
    v <- info$value
    rv$portfolio <- editData(rv$portfolio, input$groupsTable_cell_edit) # doesn't work see below
    # Warning in DT::coerceValue(v, data[i, j, drop = TRUE]) :
    #   New value(s) "test" not in the original factor levels: "Portfolio"; will be coerced to NA.
    # rv$portfolio[i,j] <- input$groupsTable_cell_edit$value
    # rv$portfolio[i,j] <- v #doesn't work

  })

}

addRowAt <- function(df, row, i) {
  # Slow but easy to understand
  if (i > 1) {
    rbind(df[1:(i - 1), ], row, df[-(1:(i - 1)), ])
  } else {
    rbind(row, df)
  }
}

deleteButtonColumn <- function(df, id, ...) {
  # function to create one action button as string
  f <- function(i) {
    # https://shiny.rstudio.com/articles/communicating-with-js.html
    as.character(actionLink(paste(id, i, sep="_"), label = 'Delete', icon = icon('trash'),
                            onclick = 'Shiny.setInputValue(\"deletePressed\",  this.id, {priority: "event"})'))
  }

  deleteCol <- unlist(lapply(seq_len(nrow(df)), f))
  # Return a data table

  DT::datatable(cbind(' ' = deleteCol, df),
                # Need to disable escaping for html as string to work
                escape = FALSE,
                editable = 'cell',
                selection = 'single',
                rownames = FALSE,
                class = 'compact',
                options = list(
                  # Disable sorting for the delete column
                  dom = 't',
                  columnDefs = list(list(targets = 1, sortable = FALSE))
                ))
}

parseDeleteEvent <- function(idstr) {
  res <- as.integer(sub(".*_([0-9]+)", "\\1", idstr))
  if (! is.na(res)) res
}

# Run the app ----
shinyApp(ui = ui, server = server)

Answer 1

据我所知，没有现成的解决方案可用。您可以尝试使用rhandsontable。它不提供 DT 表的所有功能，但允许进行编辑。上次我尝试使用它时，在某些边缘情况下存在一些小问题。 （尝试保存不同的数据类型或类似的东西。）

或者，您可以按照这些方式手动执行这些操作。这是编辑底层数据框的最小工作示例。目前我每次用户点击表格时都会覆盖它，你需要改变它来处理正常的用户行为。它仅作为概念证明。

library(DT)
library(shiny)

ui <- fluidPage(
    DT::dataTableOutput("test")
)
myDF <- iris[1:10,]
js <- c("table.on('click.dt','tr', function() {",
        "    var a = table.data();",
        "    var data = []",
        "    for (i=0; i!=a.length; i++) {",
        "         data = data.concat(a[i]) ",
        "    };",
        "Shiny.setInputValue('dataChange', data)",
        "})")

server <- function(input, output) {

    output$test <- DT::renderDataTable(
        myDF,
        editable='cell',
        callback=JS(js)
    )
    observeEvent(input$dataChange, {
        res <- cbind.data.frame(split(input$dataChange, rep(1:6, times=length(input$dataChange)/6)),
                                stringsAsFactors=F)
        colNumbers <- res[,1]
        res <- res[,2:ncol(res)]
        colnames(res) <- colnames(myDF)
        myDF <<- res
        print(myDF)
    })
}

shinyApp(ui = ui, server = server)