Обновление реактивных значений в Shiny R - PullRequest
Новая
       45

Обновление реактивных значений в Shiny R

0 голосов
/ 06 января 2020

Я понимаю, что подобные вопросы задавались, и я попробовал практически все решения, но не повезло.

В моем приложении я позволил пользователю изменять отдельные ячейки 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)

1 Ответ

0 голосов
/ 06 января 2020

Насколько я посмотрел, готового к go решения не существует. Вы можете попробовать использовать 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)
...