Datentabelle in Shiny mit Dropdown-Auswahl bearbeiten (für DT v0.19)

Lesezeit: 8 Minuten

Benutzer-Avatar
Stampfer

Ich habe den folgenden Code auf der Lösung von Stephane Laurent für die folgende Frage zu Stack Overflow basiert:

Datentabelle in Shiny mit Dropdown-Auswahl für Faktorvariablen bearbeiten

Ich habe Code hinzugefügt, um editData zu verwenden, um die Tabelle zu aktualisieren und die Aktualisierungen speichern/exportieren zu können.

Folgendes funktioniert mit DT v0.18, aber mit DT v0.19 fand ich, dass id_cell_edit nicht auszulösen scheint. Ich bin mir nicht sicher, ob es mit dem Rückruf oder möglicherweise jquery.contextMenu zu tun hat, wenn DT v0.19 auf jquery 3.0 aktualisiert wurde. Würde mich über jeden Einblick freuen, den die Leute haben könnten, wie man das durcharbeitet.

Hier ist eine Beschreibung des Verhaltens, das ich bei der Verwendung von v0.18 beobachte. Wenn ich die Verwendungsspalte auswähle und den Wert für die erste Zeile von der Standardeinstellung „sel“ auf „id“ aktualisiere, ändert sich der Wert in der DT-Tabelle. Ich sehe auch, dass die Ansicht des Tibble aktualisiert wird und somit auch die Daten in der heruntergeladenen CSV-Datei aktualisiert werden. Wenn ich zur nächsten Seite gehe, um das 11. Element anzuzeigen, und dann zur ersten Seite zurückkehre, kann ich sehen, dass der von mir aktualisierte Datensatz immer noch „id“ lautet.

Hier ist eine Beschreibung des Verhaltens, das ich bei der Verwendung von v0.19 beobachte. Wenn ich die Verwendungsspalte auswähle und den Wert für die erste Zeile von der Standardeinstellung „sel“ auf „id“ aktualisiere, ändert sich der Wert in der DT-Tabelle. Die Tibble-Ansicht wird nicht aktualisiert, und daher werden die Daten in der heruntergeladenen CSV-Datei nicht aktualisiert. Wenn ich zur nächsten Seite gehe, um das 11. Element anzuzeigen, und dann zur ersten Seite zurückkehre, wird die von mir vorgenommene Aktualisierung gelöscht.

Beachten Sie, dass ich auch reaktive Diagramme mit Reactlog ausgeführt habe. Ich habe die gleichen Schritte befolgt, um die Verwendungsspalte der ersten Zeile auf “id” zu aktualisieren. Der erste Unterschied, den ich bemerke, ist, dass reaktiveWerte###$dt in Schritt 5 mir eine Liste von 7 gibt, wenn ich Version v0.18 verwende, und eine Liste von 8, wenn ich Version v0.19 verwende. Bei Schritt 16 wird für v0.18 input$dt_cell_edit ungültig, dann Data ungültig und output$table ungültig. Bei Schritt 16 wird bei Verwendung von v0.19 jedoch output$dt ungültig und dann output$table ungültig. Mit anderen Worten, bei Verwendung von v0.19 werden input$dt_cell_edit und Data nicht ungültig gemacht.

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

cars_df <- mtcars
cars_meta <- dplyr::tibble(variables = names(cars_df), data_class = sapply(cars_df, class), usage = "sel")
cars_meta$data_class <- factor(cars_meta$data_class,  c("numeric", "character", "factor", "logical"))
cars_meta$usage <- factor(cars_meta$usage,  c("id", "meta", "demo", "sel", "text"))


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("dt"),
    br(),
    verbatimTextOutput("table"),
    br(),
    downloadButton('download',"Download the data")
    
)

server <- function(input, output){
    
    dat <- cars_meta
    
    value <- reactiveValues()
    value$dt<-
        datatable(
            dat, editable = "cell", callback = JS(callback),
            options = list(
                columnDefs = list(
                    list(
                        targets = 2,
                        className = "factor",
                        createdCell = JS(createdCell(c(levels(cars_meta$data_class), "another level")))
                    ),
                    list(
                        targets = 3,
                        className = "factor",
                        createdCell = JS(createdCell(c(levels(cars_meta$usage), "another level")))
                    )
                )
            )
        )
    
    output[["dt"]] <- renderDT({
        value$dt
        
    }, 
    server = TRUE)
    
    Data <- reactive({
        info <- input[["dt_cell_edit"]]
        if(!is.null(info)){
            info <- unique(info)
            info$value[info$value==""] <- NA
            dat <-  editData(dat, info, proxy = "dt")
        }
        dat
    })
    
    
    #output table to be able to confirm the table updates
    output[["table"]] <- renderPrint({Data()})  
    
    output$download <- downloadHandler(
        filename = function(){"Data.csv"}, 
        content = function(fname){
            write.csv(Data(), fname)
        }
    )
}

shinyApp(ui, server)

Unten habe ich die Lösung von ismirsehregal für meinen Anwendungsfall genutzt. Ich habe auch renderPrint/verbatimTextOutput hinzugefügt, um zu veranschaulichen, was ich mit den zugrunde liegenden Daten zu tun versuche. Ich möchte in der Lage sein, die Werte und nicht die Eingabecontainer zu erfassen. Im Wesentlichen versuche ich mit dem Code, dem Benutzer einen Datensatz zu geben, ihm zu erlauben, einige Werte zu ändern, aber die Auswahlmöglichkeiten mit Dropdowns einzuschränken, und dann den aktualisierten Datensatz für die weitere Verarbeitung zu verwenden. An diesem Punkt der Lösung weiß ich nicht, wie ich an den aktualisierten Datensatz komme, damit ich ihn beispielsweise zum Exportieren in eine CSV-Datei verwenden kann.

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


cars_df <- mtcars
selectInputIDa <- paste0("sela", 1:length(cars_df))
selectInputIDb <- paste0("selb", 1:length(cars_df))

initMeta <- dplyr::tibble(
    variables = names(cars_df), 
    data_class = sapply(selectInputIDa, function(x){as.character(selectInput(inputId = x, label = "", choices = c("character","numeric", "factor", "logical"), selected = sapply(cars_df, class)))}),
    usage = sapply(selectInputIDb, function(x){as.character(selectInput(inputId = x, label = "", choices = c("id", "meta", "demo", "sel", "text"), selected = "sel"))})
)



ui <- fluidPage(
    DT::dataTableOutput(outputId = 'my_table'),
    br(),
    verbatimTextOutput("table")
)


server <- function(input, output, session) {
    
    
    displayTbl <- reactive({
        dplyr::tibble(
            variables = names(cars_df), 
            data_class = sapply(selectInputIDa, function(x){as.character(selectInput(inputId = x, label = "", choices = c("numeric", "character", "factor", "logical"), selected = input[[x]]))}),
            usage = sapply(selectInputIDb, function(x){as.character(selectInput(inputId = x, label = "", choices = c("id", "meta", "demo", "sel", "text"), selected = input[[x]]))})
        )
    })
    
    

    
    output$my_table = DT::renderDataTable({
        DT::datatable(
            initMeta, escape = FALSE, selection = 'none', rownames = FALSE,
            options = list(paging = FALSE, ordering = FALSE, scrollx = TRUE, dom = "t",
                           preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
                           drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
            )
        )
    }, server = TRUE)
    
    my_table_proxy <- dataTableProxy(outputId = "my_table", session = session)
    
    observeEvent({sapply(selectInputIDa, function(x){input[[x]]})}, {
        replaceData(proxy = my_table_proxy, data = displayTbl(), rownames = FALSE) # must repeat rownames = FALSE see ?replaceData and ?dataTableAjax
    }, ignoreInit = TRUE)
    
    observeEvent({sapply(selectInputIDb, function(x){input[[x]]})}, {
        replaceData(proxy = my_table_proxy, data = displayTbl(), rownames = FALSE) # must repeat rownames = FALSE see ?replaceData and ?dataTableAjax
    }, ignoreInit = TRUE)
    
    
    
    output$table <- renderPrint({displayTbl()})  
    
    
}

shinyApp(ui = ui, server = server)

  • Du hast geschrieben, dass das nicht funktioniert. Besteht jedoch die Möglichkeit, dass das Problem darin besteht, dass eine bestimmte Funktion nicht funktioniert? Ich habe DT .19 und habe den Ursprung des Codes mit der von Ihnen angegebenen URL besucht. Ich sehe den Tisch; Ich kann Zeilen bearbeiten und hervorheben. Das Herunterladen funktioniert. Was vermisse ich?

    – Kat

    14. November 2021 um 6:36 Uhr

  • Kat, danke, dass du dir die Zeit genommen hast, dir das anzusehen. Ich habe mehr Kontext dazu hinzugefügt, welches Verhalten ich sehe, und anschließend einige Vergleiche mit dem von mir ebenfalls aufgenommenen Reactlog durchgeführt.

    – Stampfer

    14. November 2021 um 15:38 Uhr

  • Hast du darüber nachgedacht, das JS zu überspringen? Schauen Sie sich diese Beispiele an.

    – Kat

    15. November 2021 um 8:25 Uhr

  • Und dieser verwandte Beitrag.

    – ismirsehregal

    15. November 2021 um 9:59 Uhr

  • @ismirsehregal Genau das wollte ich tun. Offensichtlich hatte ich meinen Kopf nicht genug darum gewickelt, um diesen letzten Schritt auszuarbeiten. Es ist eine elegante Lösung. Vielen Dank.

    – Stampfer

    17. November 2021 um 2:15 Uhr

Benutzer-Avatar
ismirsehregal

Um das zu bekommen resultTbl Sie können einfach auf die zugreifen input[x]‘s:

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

cars_df <- mtcars
selectInputIDa <- paste0("sela", 1:length(cars_df))
selectInputIDb <- paste0("selb", 1:length(cars_df))

initMeta <- dplyr::tibble(
  variables = names(cars_df), 
  data_class = sapply(selectInputIDa, function(x){as.character(selectInput(inputId = x, label = "", choices = c("character","numeric", "factor", "logical"), selected = sapply(cars_df, class)))}),
  usage = sapply(selectInputIDb, function(x){as.character(selectInput(inputId = x, label = "", choices = c("id", "meta", "demo", "sel", "text"), selected = "sel"))})
)

ui <- fluidPage(
  DT::dataTableOutput(outputId = 'my_table'),
  br(),
  verbatimTextOutput("table")
)

server <- function(input, output, session) {

  displayTbl <- reactive({
    dplyr::tibble(
      variables = names(cars_df), 
      data_class = sapply(selectInputIDa, function(x){as.character(selectInput(inputId = x, label = "", choices = c("numeric", "character", "factor", "logical"), selected = input[[x]]))}),
      usage = sapply(selectInputIDb, function(x){as.character(selectInput(inputId = x, label = "", choices = c("id", "meta", "demo", "sel", "text"), selected = input[[x]]))})
    )
  })
  
  resultTbl <- reactive({
    dplyr::tibble(
      variables = names(cars_df), 
      data_class = sapply(selectInputIDa, function(x){input[[x]]}),
      usage = sapply(selectInputIDb, function(x){input[[x]]})
    )
  })
  
  output$my_table = DT::renderDataTable({
    DT::datatable(
      initMeta, escape = FALSE, selection = 'none', rownames = FALSE,
      options = list(paging = FALSE, ordering = FALSE, scrollx = TRUE, dom = "t",
                     preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
                     drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
      )
    )
  }, server = TRUE)
  
  my_table_proxy <- dataTableProxy(outputId = "my_table", session = session)
  
  observeEvent({sapply(selectInputIDa, function(x){input[[x]]})}, {
    replaceData(proxy = my_table_proxy, data = displayTbl(), rownames = FALSE) # must repeat rownames = FALSE see ?replaceData and ?dataTableAjax
  }, ignoreInit = TRUE)
  
  observeEvent({sapply(selectInputIDb, function(x){input[[x]]})}, {
    replaceData(proxy = my_table_proxy, data = displayTbl(), rownames = FALSE) # must repeat rownames = FALSE see ?replaceData and ?dataTableAjax
  }, ignoreInit = TRUE)
  
  output$table <- renderPrint({resultTbl()})  
  
}

shinyApp(ui = ui, server = server)

1016340cookie-checkDatentabelle in Shiny mit Dropdown-Auswahl bearbeiten (für DT v0.19)

This website is using cookies to improve the user-friendliness. You agree by using the website further.

Privacy policy