Search code examples
rinputshinyselectinput

How to prevent output from running twice when inputs are inter-dependent?


I'm developping an R Shiny-based application. I want to keep my input consistent with available data, thus I update the selected values in selectInput. When I change selected value in input 1, then the value of input 2 is updated, then the data is updated (just once). OK BUT if I change selected value in input 2, then the data is updated, then the value of input 1 is updated, then the data is updated AGAIN. Check out the "check latest_value" that is printed twice.

Initially I used renderUI rather than updateSelectInput, but at initialisation, the data is computed twice.

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)

That's why I decided to use updateSelectInput based on this Alternate control of a sliderInput between a derived value and user selected value but the sequential structure of the code makes the data to be computed twice when I change input 2 value.

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)

Fixes like this one don't work in that case because I'm not trying to achieve the same thing three interdependent selectInput in R/Shiny application

I want the default selected value of each input to be consistent so that the filter returns at least 1 value. This of any input I change.


Solution

  • Interesting problem and not easy to solve! Interestingly, what you are asking for is not what you need. Observation:

    1. If the user selects Qn2 while Input1 is "Mississippi", you first set Input1 on Quebec and then hard set Input2 on Qn1, changing the choise of the user. This is bad.
    2. Datatable is always updated once any of the two inputs changes, hence the many re-calculations of the table.

    The solution therefore is twofold:

    1. Don't overwrite the user's choice of e.g. Qc2 to Qc1. I used an if condition for that.
    2. Install a watchguard to only update the datatable when its contents actually changed. I do this with a reactiveVal() that I only update when the choice of the two inputs was valid (i.e. when the result set is greater than 0).

    See the result below. Watch the console output to observe the decisions.

    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