R语言保留widget的值并在DTtable中添加新行？

quhf5bfb 于 2023-02-06 发布在其他

关注(0)|答案(1)|浏览(123)

我有一个带有下拉输入和复选框的React式DTtable，当我添加新行时，小部件的值不会保存在内存中，表会重新加载所有先前行的默认值。
我想在添加新行时保留先前行中不同小部件的先前值？

library(shiny)
library(shinyjs)
library(DT)
library(dplyr)


# Create a dataset
data_survey <- data.frame(question = c("Quel est votre âge?"),
                   option = c(NA),
                   type = c(as.character(selectInput(paste0("type_", 1),
                                                     "",
                                                     choices = c("numérique","texte","choix multiple","selection","oui/non","matrice"),
                                                     width = "100px"))),
                   id = c("age"),
                   dependence = c(as.character(checkboxInput(paste0("dependency_", 1),"",FALSE))),
                   valeur_dependence = c(NA),
                   reponse_obligatoire = c(as.character(checkboxInput(paste0("obligatory_", 1),"",FALSE))))

colnames(data_survey) <- c("Question", "Option", "Type", "Id", "Dépendence", "Valeur de la dépendence", "Réponse obligatoire")

# Define the UI

ui <- fluidPage(titlePanel("Créer son questionnaire"),
                
  tags$head(tags$link(rel = "stylesheet", type = "text/css", href = "www/style.css")
  ),
  
  
  DT::dataTableOutput("table"),
  br(),
  actionButton("add_row", "Ajouter une ligne"),
  actionButton("delete_row", "Supprimer la ligne sélectionnée"),
  actionButton("create_survey", "Prévisualiser"),
  br(),
  br(),
  br(),
  br(),
  br(),
  verbatimTextOutput('type'),
)

server <- function(input, output, session) {
  
  rv <- reactiveValues(data=data_survey)
  
  output$table = DT::renderDataTable(
    rv$data, escape = FALSE, editable = TRUE, selection = 'single', server = FALSE,
    options = list(dom = 't', paging = FALSE, ordering = FALSE),
    callback = JS("table.rows().every(function(i, tab, row) {
        var $this = $(this.node());
        $this.attr('id', this.data()[0]);
        $this.addClass('shiny-input-container');
      });
      Shiny.unbindAll(table.table().node());
      Shiny.bindAll(table.table().node());")
  )
  

  observeEvent(input$add_row, {
    
    new_data <-  c(NA,
                   NA,
                   as.character(selectInput(paste0("type_", nrow(rv$data) + 1),
                                            "",
                                            choices = c("numérique","texte","choix multiple","selection","oui/non","matrice"),
                                            width = "100px")),
                   NA,
                   as.character(checkboxInput(paste0("dependency_", nrow(rv$data) + 1),"",FALSE)),
                   NA, 
                   as.character(checkboxInput(paste0("obligatory_", nrow(rv$data) + 1),"",FALSE)))

    rv$data <- rbind(rv$data, new_data)
      
  })
  
  output$type = renderPrint({
    
    str(sapply(1:nrow(rv$data), function(i) input[[paste0("type_", i)]]))
    str(sapply(1:nrow(rv$data), function(i) input[[paste0("obligatory_", i)]]))
  })
}

shinyApp(ui, server)

r

来源：https://stackoverflow.com/questions/75313079/keep-the-values-of-widgets-and-adding-a-new-row-in-dttable

1条答案

按热度按时间

rsaldnfx1#

您可以通过代理和DT提供的addRow函数来实现这一点，然后您的datatable不再以这种方式响应rv$data，如果您希望能够删除一行，则需要使用JavaScript方法-请参见here。

library(shiny)
library(DT)

# Create a dataset
data_survey <- data.frame(
  question = "Quel est votre âge?",
  option = NA,
  type = as.character(
    selectInput(
      paste0("type_", 1),
      "",
      choices = c(
        "numérique", "texte", "choix multiple", "selection", "oui/non", "matrice"
      ),
      width = "100px"
    )
  ),
  id = "age",
  dependence = as.character(
    checkboxInput(paste0("dependency_", 1), "", FALSE)
  ),
  valeur_dependence = NA,
  reponse_obligatoire = 
    as.character(checkboxInput(paste0("obligatory_", 1), "", FALSE))
)

colnames(data_survey) <- c(
  "Question", "Option", "Type", "Id", "Dépendence", "Valeur de la dépendence", 
  "Réponse obligatoire"
)

# Define the UI

ui <- fluidPage(
  titlePanel("Créer son questionnaire"),
  tags$head(
    tags$link(rel = "stylesheet", type = "text/css", href = "style.css")
  ),
  DTOutput("table"),
  br(),
  actionButton("add_row",       "Ajouter une ligne"),
  actionButton("delete_row",    "Supprimer la ligne sélectionnée"),
  actionButton("create_survey", "Prévisualiser"),
  br(),
  br(),
  br(),
  br(),
  br(),
  verbatimTextOutput("type")
)

server <- function(input, output, session) {
  rv <- reactiveValues(data = data_survey)
  
  output$table <- renderDT({
    datatable(
      data_survey,
      escape = FALSE, editable = TRUE, selection = "single",
      options = list(
        dom      = "t", 
        paging   = FALSE,
        ordering = FALSE,
        preDrawCallback = 
          JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
        drawCallback    = 
          JS('function() { Shiny.bindAll(this.api().table().node()); }')
      ),
      
    )
  }, server = FALSE)
  
  proxy <- dataTableProxy("table")
  
  observeEvent(input$add_row, {
    i <- nrow(rv$data) + 1
    new_data <- c(
      NA,
      NA,
      as.character(
        selectInput(
          paste0("type_", i),
          "",
          choices = c(
            "numérique", "texte", "choix multiple", "selection", 
            "oui/non", "matrice"
          ),
          width = "100px"
        )),
      NA,
      as.character(
        checkboxInput(paste0("dependency_", i), "", FALSE)
      ),
      NA,
      as.character(
        checkboxInput(paste0("obligatory_", i), "", FALSE)
      )
    )
    rv$data <- rbind(rv$data, new_data)
    
    addRow(proxy, rv$data[i, ], resetPaging = FALSE)
  })
  
  output$type <- renderPrint({
    str(sapply(
      1:nrow(rv$data), 
      function(i) input[[paste0("type_", i)]]
    ))
    str(sapply(
      1:nrow(rv$data), 
      function(i) input[[paste0("obligatory_", i)]]
    ))
  })
  
}

shinyApp(ui, server)

赞(0）回复(0）举报 2023-02-06

我来回答

R语言保留widget的值并在DTtable中添加新行？

1条答案

相关问题

热门标签

最新问答

R语言 保留widget的值并在DTtable中添加新行？

1条答案

相关问题

热门标签

最新问答

R语言保留widget的值并在DTtable中添加新行？