Сложная проблема связывания ввода R с блестящим - PullRequest
Новая
       6

Сложная проблема связывания ввода R с блестящим

0 голосов
/ 27 июня 2018

Я пытаюсь что-то сделать немного хитро, и я надеюсь, что кто-то может мне помочь.

Я бы хотел добавить selectInput в таблицу данных. Если я запускаю приложение, я вижу, что входы col_1, col_2 .. хорошо связаны с данными (вы можете переключиться на a, b или c)

НО Если я обновлю набор данных (с iris до mtcars), связь между входными данными и данными будет потеряна. Теперь, если вы измените selectinput, журнал не покажет изменения. Как я могу сохранить ссылки?

Я провел некоторый тест, используя shiny.bindAll() и shiny.unbindAll(), но безуспешно.

Есть идеи?

Пожалуйста, посмотрите на приложение: 

library(shiny)
library(DT)
library(shinyjs)
library(purrr)

    ui <- fluidPage(
      selectInput("data","choose data",choices = c("iris","mtcars")),
      DT::DTOutput("tableau"),
      verbatimTextOutput("log")
    )

    server <- function(input, output, session) {
      dataset <- reactive({
        switch (input$data,
          "iris" = iris,
          "mtcars" = mtcars
        )
      })

      output$tableau <- DT::renderDT({
        col_names<-
          seq_along(dataset()) %>% 
        map(~selectInput(
          inputId = paste0("col_",.x),
          label = NULL, 
          choices = c("a","b","c"))) %>% 
          map(as.character)

        DT::datatable(dataset(),
                  options = list(ordering = FALSE, 
                          preDrawCallback = JS("function() {
                                               Shiny.unbindAll(this.api().table().node()); }"),
                         drawCallback = JS("function() { Shiny.bindAll(this.api().table().node());
                         }")
          ),
          colnames = col_names, 
          escape = FALSE         
        )

      })
      output$log <- renderPrint({
        lst <- reactiveValuesToList(input)
        lst[order(names(lst))]
      })

    }

    shinyApp(ui, server)

1 Ответ

0 голосов
/ 30 июня 2018

Понимание вашей задачи:

Для того, чтобы определить свою задачу, вам нужно знать две вещи.

  1. Если данные обновляются, они будут «удалены» и построены из царапина (не уверен на 100%, я думаю, что где-то читал)
  2. Имейте в виду, что вы по сути создаете HTML-страницу.

selectInput() - это просто оболочка для HTML-кода. Если вы наберете selectInput("a", "b", "c") в консоли, он вернет: 

<div class="form-group shiny-input-container">
  <label class="control-label" for="a">b</label>
  <div>
    <select id="a"><option value="c" selected>c</option></select>
    <script type="application/json" data-for="a" data-nonempty="">{}</script>
  </div>
</div>

Обратите внимание, что вы строите <select id="a">, выбор с помощью id="a". Поэтому, если мы предположим, что 1) правильно после обновления, вы пытаетесь создать другой элемент HTML: <select id="a"> с существующим идентификатором. Это не должно работать: Могут ли несколько разных элементов HTML иметь одинаковый идентификатор, если они разные элементы? . (При условии, что мое предположение 1) верно;))

Решение вашей задачи:

На первый взгляд довольно просто: убедитесь, что используемый вами идентификатор уникален в созданном HTML-документе.

Очень быстрый и грязный способ - заменить: 

inputId = paste0("col_",.x)

с чем-то вроде: inputId = paste0("col_", 1:nc, "-", sample(1:9999, nc)).

Но потом вам будет трудно его использовать.

Длинный путь:

Так что вы можете использовать какую-то память

  1. Какие идентификаторы вы уже использовали.
  2. Какие из ваших текущих идентификаторов используются.

Вы можете использовать 

  global <- reactiveValues(oldId = c(), currentId = c())

за это.

Идея отфильтровать старые использованные идентификаторы и извлечь текущие идентификаторы может быть такой: 

    lst <- reactiveValuesToList(input)
    lst <- lst[setdiff(names(lst), global$oldId)]
    inp <- grepl("col_", names(lst))
    names(lst)[inp] <- sapply(sapply(names(lst)[inp], strsplit, "-"), "[", 1)

Воспроизводимый пример будет выглядеть так: 

library(shiny)
library(DT)
library(shinyjs)
library(purrr)

ui <- fluidPage(
  selectInput("data","choose data",choices = c("iris","mtcars")),
  dataTableOutput("tableau"),
  verbatimTextOutput("log")
)

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

  global <- reactiveValues(oldId = c(), currentId = c())

  dataset <- reactive({
    switch (input$data,
            "iris" = iris,
            "mtcars" = mtcars
    )
  })

  output$tableau <- renderDataTable({
    isolate({
      global$oldId <- c(global$oldId, global$currentId)
      nc <- ncol(dataset())
      global$currentId <- paste0("col_", 1:nc, "-", sample(setdiff(1:9999, global$oldId), nc))

      col_names <-
        seq_along(dataset()) %>% 
        map(~selectInput(
          inputId = global$currentId[.x],
          label = NULL, 
          choices = c("a","b","c"))) %>% 
        map(as.character)
    })    
    DT::datatable(dataset(),
                  options = list(ordering = FALSE, 
                                 preDrawCallback = JS("function() {
                                                      Shiny.unbindAll(this.api().table().node()); }"),
                                 drawCallback = JS("function() { Shiny.bindAll(this.api().table().node());
}")
          ),
          colnames = col_names, 
          escape = FALSE         
    )

})
  output$log <- renderPrint({
    lst <- reactiveValuesToList(input)
    lst <- lst[setdiff(names(lst), global$oldId)]
    inp <- grepl("col_", names(lst))
    names(lst)[inp] <- sapply(sapply(names(lst)[inp], strsplit, "-"), "[", 1)
    lst[order(names(lst))]
  })

}

shinyApp(ui, server)
...