Как предотвратить двойной запуск выхода, когда входы взаимозависимы? - PullRequest
Новая
       6

Как предотвратить двойной запуск выхода, когда входы взаимозависимы?

0 голосов
/ 12 апреля 2019

Я разрабатываю приложение на основе R Shiny. Я хочу, чтобы мой ввод соответствовал доступным данным, поэтому я обновляю выбранные значения в selectInput. Когда я изменяю выбранное значение на входе 1, то значение на входе 2 обновляется, затем данные обновляются (только один раз). Хорошо НО, если я изменю выбранное значение на входе 2, тогда данные обновляются, затем значение на входе 1 обновляется, а затем данные обновляются СНОВА. Проверьте "check latest_value", который напечатан дважды.

Изначально я использовал renderUI, а не updateSelectInput, но при инициализации данные вычисляются дважды. 

library(shiny)
library(DT)
library(dplyr)
my_data=data.frame(CO2)
# Running a Shiny app object
app <- shinyApp(
  ui = bootstrapPage(
    selectInput('type','Choix du type',choices = unique(my_data$Type)),
    uiOutput('plant_ui'),
    DTOutput('plot')
  ),
  server = function(input, output) {

    data=reactive({
      # req(input$type)
      my_data_temp=my_data
      if(length(input$type)>0){
        my_data_temp=my_data_temp%>%filter(Type%in%input$type)
      }
      if(length(input$plant)>0){
        my_data_temp=my_data_temp%>%filter(Plant%in%input$plant)
      }

      my_data_temp
    })

    latest_plant_value=reactive({
      if(is.null(input$plant))data()$Plant[1]
      else input$plant
    })


    output$plant_ui=renderUI({
      sub_data=data()
      selectInput(inputId = 'plant',"filtre par plant",choices = unique(sub_data$Plant),
                  selected=latest_plant_value())
    })

    output$plot <- renderDT({ 
      print("check latest_value")
      datatable(data()) })
  }
)
runApp(app)

Именно поэтому я решил использовать updateSelectInput на основе этого Альтернативное управление sliderInput между производным значением и выбранным пользователем значением , но последовательная структура кода делает данные для вычисления дважды при изменении ввода 2 значения. 

library(shiny)
library(DT)
library(dplyr)
my_data=data.frame(CO2)
# Running a Shiny app object
app <- shinyApp(
  ui = bootstrapPage(
    selectInput('type','Choix du type',choices = unique(my_data$Type),selected=my_data$Type[1]),
    selectInput('plant','Choix du type',choices = unique(my_data$Plant),selected=my_data$Plant[1]),
    DTOutput('plot')
  ),
  server = function(input, output,session) {

    data=reactive({
      # req(input$type)
      my_data_temp=my_data
      if(length(input$type)>0){
        my_data_temp=my_data_temp%>%filter(Type%in%input$type)
      }
      if(length(input$plant)>0){
        my_data_temp=my_data_temp%>%filter(Plant%in%input$plant)
      }

      my_data_temp
    })

    observeEvent(input$type,{
      print("update type changed")
      updateSelectInput(session, "plant",
                        selected =  unique(my_data%>%filter(Type%in%input$type)%>%.$Plant)[1])
    })
    observeEvent(input$plant,{
      print("update plant changed")
      updateSelectInput(session, "type",
                        selected =  unique(my_data%>%filter(Plant%in%input$plant)%>%.$Type)[1])
    })

   output$plot <- renderDT({ 
     print("check latest_value")

     datatable(data()) })
  }
)
runApp(app)

Исправления, подобные этой, в этом случае не работают, потому что я не пытаюсь достичь того же самого три взаимозависимых selectInput в приложении R / Shiny

Я хочу, чтобы выбранное по умолчанию значение каждого входа было согласованным, чтобы фильтр возвращал хотя бы 1 значение. Это любой ввод, который я изменяю.

Ответы [ 2 ]

1 голос
/ 12 апреля 2019

Интересная проблема и ее нелегко решить!Интересно, что вы просите не то, что вам нужно.Наблюдение:

  1. Если пользователь выбирает Qn2 , когда Input1 - "Миссисипи", вы сначала устанавливаете Input1 на Квебек , а затем жесткий набор Input2 on Qn1 , изменяющий выбор пользователя.Это плохо.
  2. Datatable всегда обновляется при изменении любого из двух входов, что приводит к многочисленным пересчетам таблицы.

Поэтому решение имеет два аспекта:

  1. Не перезаписывайте выбор пользователя, например: Qc2 на Qc1 .Для этого я использовал условие if .
  2. Установите watchguard , чтобы обновлять данные только тогда, когда его содержимое действительно изменилось.Я делаю это с помощью реактивныйВал () , который я обновляю только тогда, когда выбор двух входов был действительным (т. Е. Когда набор результатов больше 0).

См.результат ниже.Наблюдайте за выходом консоли, чтобы наблюдать за решениями. 

library(shiny)
library(DT)
library(dplyr)
my_data=data.frame(CO2)

shinyApp(
  ui = bootstrapPage(
    selectInput('type','Choix du type',choices = unique(my_data$Type),selected=my_data$Type[1]),
    selectInput('plant','Choix du plant',choices = unique(my_data$Plant),selected=my_data$Plant[1]),
    DTOutput('plot')
  ),
  server = function(input, output,session) {

    latest_data <- reactiveVal(my_data)
    observe({
      result <- my_data %>% filter(Type %in% input$type, Plant %in% input$plant)

      if(nrow(result) > 0){
        latest_data(result)
      }else{
        cat(format(Sys.time(), "%H:%M:%S"), "Didn't update the dataframe because the choice was not valid.\n")
      }
    })

    observeEvent(input$type,{
      if(! input$plant %in% my_data$Plant[my_data$Type == input$type]){
        old <- input$plant
        new <- my_data %>% filter(Type %in% input$type) %>% slice(1) %>% pull(Plant) %>% as.character()
        updateSelectInput(session, "plant", selected = new)
        cat(format(Sys.time(), "%H:%M:%S"), "Updated input$plant from", old, "to", new, "so that it represents a valid choice for", input$type, "\n")
      }else{
        cat(format(Sys.time(), "%H:%M:%S"), "Didn't update input$plant", input$plant, "because it is a valid choice for", input$type, "already\n")
      }
    })
    observeEvent(input$plant,{
        updateSelectInput(session, "type",
                          selected = my_data %>% filter(Plant %in% input$plant) %>% slice(1) %>% pull(Type))
    })

    output$plot <- renderDT({ 
      cat(format(Sys.time(), "%H:%M:%S"), "updating datatable to only include", isolate(input$plant), "and", isolate(input$type), "\n\n")
      latest_data()
      datatable(latest_data())
    })
  }
)

gif of solution

1 голос
/ 12 апреля 2019

Один из способов обойти это - создать reactiveVal, который сообщает приложению, что выполняется операция обновления, и требует data, чтобы дождаться, пока этот флаг вернется к False, перед запуском.

Я добавил 5 строк во второе блестящее приложение:

К server(): 

# Create update in progress flag
updating_type_inprogress <- reactiveVal(FALSE)

К observeEvent(input$type ...: 

# When type is changed, set flag to TRUE
updating_type_inprogress(TRUE)

К observeEvent(input$plant ...: 

# Once this function has run, the updating operation is done
updating_type_inprogress(FALSE)

К data(): 

# Stops updating data() if the in-progress flag is TRUE
req(!updating_type_inprogress())

К renderDT(): 

# Stops updating renderDT() if the in-progress flag is TRUE
#  this is probably optional unless there's resource-intensive code
#    that doesn't depend on changes in data()
req(!updating_type_inprogress())

Вот весь код: 

library(shiny)
library(DT)
library(dplyr)
my_data=data.frame(CO2)
# Running a Shiny app object
app <- shinyApp(
    ui = bootstrapPage(
        selectInput('type','Choix du type',choices = unique(my_data$Type),selected=my_data$Type[1]),
        selectInput('plant','Choix du type',choices = unique(my_data$Plant),selected=my_data$Plant[1]),
        DTOutput('plot')
    ),
    server = function(input, output,session) {

        data=reactive({
            req(!updating_type_inprogress())
            print(input$type)
            print(input$plant)
            my_data_temp=my_data
            if(length(input$type)>0){
                my_data_temp=my_data_temp%>%filter(Type%in%input$type)
            }
            if(length(input$plant)>0){
                my_data_temp=my_data_temp%>%filter(Plant%in%input$plant)
            }

            my_data_temp
        })

        observeEvent(input$type,{
            updating_type_inprogress(TRUE)
            updateSelectInput(session, "plant",
                              selected =  unique(my_data%>%filter(Type%in%input$type)%>%.$Plant)[1])
        })
        observeEvent(input$plant,{
            updating_type_inprogress(FALSE)
            updateSelectInput(session, "type",
                              selected =  unique(my_data%>%filter(Plant%in%input$plant)%>%.$Type)[1])
        })

        updating_type_inprogress <- reactiveVal(FALSE)

        output$plot <- renderDT({ 
            req(!updating_type_inprogress())
            print("check latest_value")
            datatable(data()) })
    }
)
runApp(app)

Как видно, при изменении input$type функции data() и renderDT() запускаются только один раз с правильно обновленными значениями: 

[1] "check latest_value"
[1] "Quebec"
[1] "Qn1"
[1] "check latest_value"
[1] "Mississippi"
[1] "Mn1"
[1] "check latest_value"
[1] "Quebec"
[1] "Qn1"
...