在 Shiny R 中更新reactiveValues

Question

我知道有人問過類似的問題，而且我幾乎嘗試了所有解決方案，但都沒有成功。

在我的應用程序中，我允許用戶修改 DT::datatable 的單個單元格。 數據表的來源是一個反應式數據框。 用戶對客戶端數據表進行更改后，數據表源保持不變。 這是稍后的問題，當我允許用戶向數據表添加行時，該行被添加到源數據表中，然后客戶端數據表反映此更改。 然而，這意味着如果用戶對客戶端數據表中的單元格進行更改，當用戶向同一個表中添加一行時，用戶所做的更改將被遺忘，因為它從未對源進行過。

我嘗試了很多方法來更新底層/服務器端數據表，但都沒有運氣。 editData 不斷給我錯誤/不適用。 我也嘗試索引服務器端表並將更改的值放入其中，但沒有成功。 我將在下面發布我的代碼，並附上一些關於具體細節的評論..

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 。 它不提供設備標識符表的所有功能，但允許進行編輯。 上次我嘗試使用它時，在某些邊緣情況下出現了一些小問題。 （試圖保存不同的數據類型或類似的東西。）

或者，您可以按照這些方式手動完成這些工作。 這是編輯基礎數據框的最小工作示例。 目前我每次用戶點擊表格時都會覆蓋它，你需要改變它來處理正常的用戶行為。 它僅作為概念證明。

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)