observeEvent in Shiny module using a function

shiny
, , ,
1

I got this answer previously: observeEvent in Shiny using functions but I am having trouble implementing this using modules.

I am looking to update the inputs, via a function. Updating one radio button should update the others. I have tried to update the previous answer, but I can't quite get it to work.

So this works, but doesn't use a function:

library(shinydashboard)
library(shiny)
library(glue)
library(rlang)
library(tidyverse)

# module --------------
# Choice of variables
choice_ui <- function(id) {
  ns <- NS(id)
  tagList(
    radioButtons(ns("species"), 
                 label = "species", 
                 choices = unique(iris$Species),
                 selected = "setosa")
  )
}

choice_server <- function(id, rv) {
  moduleServer(id, function(input, output, session) {
    # Whenever the choice changes, the value inside rv is set
    observeEvent(input$species, {
      rv$species <- input$species
    })
    
  })
}

# app -------------
ui <- dashboardPage(
  dashboardHeader(title = "test"),
  dashboardSidebar(
    
    sidebarMenu(id = "tabs",
                
                # Introduction -----------------------------------------------------------
                menuItem("tab1", tabName = "tab1"),
                conditionalPanel("input.tabs == 'tab1'",
                                 choice_ui("sp1")
                ),
                
                # Current applications -----------------------------------------------------------
                menuItem("tab2", tabName = "tab2"),
                conditionalPanel("input.tabs == 'tab2'",
                                 choice_ui("sp2")
                ),
                
                
                # Completed applications -----------------------------------------------------------
                menuItem("tab3", tabName = "tab3"),
                conditionalPanel("input.tabs == 'tab3'",
                                 choice_ui("sp3")
                )
    )
  ),
  dashboardBody(
    "Not relevant."
  )
)

server <- function(input, output, session) {
  
  # reactive values ----------
  rv <- reactiveValues()
  
  # observe normally ----------
  # this works
  observeEvent(input[['sp1-species']],{
                   updateRadioButtons(session,
                                     'sp2-species',
                                      selected = input[['sp1-species']])
                   updateRadioButtons(session,
                                      'sp3-species',
                                      selected = input[['sp1-species']])
  })

  observeEvent(input[['sp2-species']],{
    updateRadioButtons(session,
                       'sp1-species',
                       selected = input[['sp2-species']])
    updateRadioButtons(session,
                       'sp3-species',
                       selected = input[['sp2-species']])
  })

  observeEvent(input[['sp3-species']],{
    updateRadioButtons(session,
                       'sp2-species',
                       selected = input[['sp3-species']])
    updateRadioButtons(session,
                       'sp3-species',
                       selected = input[['sp3-species']])
  })
  
  # module servers
  choice_server("sp1", rv = rv)
  choice_server("sp2", rv = rv)
  choice_server("sp3", rv = rv)
  
}

shinyApp(ui, server)

This is the code using a function, but it doesn't update the inputs properly. There are some outputs printed in the console for testing purposes if that is helpful.

library(shinydashboard)
library(shiny)
library(glue)
library(rlang)
library(tidyverse)

# module --------------
# Choice of variables
choice_ui <- function(id) {
  ns <- NS(id)
  tagList(
    radioButtons(ns("species"), 
                 label = "species", 
                 choices = unique(iris$Species),
                 selected = "setosa")
  )
}

choice_server <- function(id, rv) {
  moduleServer(id, function(input, output, session) {
    # Whenever the choice changes, the value inside rv is set
    observeEvent(input$species, {
      rv$species <- input$species
    })
    
  })
}


# function ----------------

species_observer <- function(source){
  others <- setdiff(c('sp1-species','sp2-species','sp3-species'), source)
  glue("
 observeEvent(input[['{source}']],
       {{
       
       # just looking at the outputs ---
       print('{source}') 
       print(input[['{source}']]) 
       print(paste('first: ', input[['{others[1]}']])) # not quite right
       print(paste('second: ', input[['{others[2]}']])) # not quite right
       
       # update ----
    updateRadioButtons(session,
                      input[['{others[1]}']],
                       selected = input[['{source}']])
    updateRadioButtons(session,
                       input[['{others[2]}']],
                       selected = input[['{source}']])
  }})")
}


# app -------------
ui <- dashboardPage(
  dashboardHeader(title = "test"),
  dashboardSidebar(
    
    sidebarMenu(id = "tabs",
                
                # Introduction -----------------------------------------------------------
                menuItem("tab1", tabName = "tab1"),
                conditionalPanel("input.tabs == 'tab1'",
                                 choice_ui("sp1")
                ),
                
                # Current applications -----------------------------------------------------------
                menuItem("tab2", tabName = "tab2"),
                conditionalPanel("input.tabs == 'tab2'",
                                 choice_ui("sp2")
                ),
                
                
                # Completed applications -----------------------------------------------------------
                menuItem("tab3", tabName = "tab3"),
                conditionalPanel("input.tabs == 'tab3'",
                                 choice_ui("sp3")
                )
    )
  ),
  dashboardBody(
    "Note the outputs being printed in the console."
  )
)

server <- function(input, output, session) {
  
  # reactive values ----------
  rv <- reactiveValues()

  #  observe using function ----------
  walk(paste0("sp", 1:3, "-species"),
       ~eval(parse_expr(species_observer(.x))))
  
  
  
  # module servers
  choice_server("sp1", rv = rv)
  choice_server("sp2", rv = rv)
  choice_server("sp3", rv = rv)
  
}

shinyApp(ui, server)
2

this species_observer should work in your last shared code

species_observer <- function(source){
  others <- setdiff(c('sp1-species','sp2-species','sp3-species'), source)
    glue("    
 observeEvent(input[['{source}']],{{
    updateRadioButtons(session,
                      '{others[1]}',
                       selected = input[['{source}']])
    updateRadioButtons(session,
                       '{others[2]}',
                       selected = input[['{source}']])
  }})")
}
1 Like
3

Great. Thanks again for your help. I thought I had tried that, but obviously not.

4

Sorry @nirgrahamuk , I simplified my reprex too much. The selectors in my app are slightly more complex. The radiobutton input updates the selectizeInput.

This uses a function for the observer like in your answer, but produces this error:

Warning: Error in validate_session_object: object 'session' not found

As far as I can tell, it runs the same way. I also tried something using walk2() and that didn't work either. I've been playing around with it for a while, but can't spot the issue. session is used in the server and it runs fine when only using the first observer function (and also using walk2() with a dummy second argument).

The second version runs fine, but observes the long way without a function.

library(shinydashboard)
library(shiny)
library(glue)
library(rlang)
library(tidyverse)

# module --------------
# Choice of variables
choice_ui <- function(id) {
  ns <- NS(id)
  tagList(
    radioButtons(ns("species"), 
                 label = "species", 
                 choices = unique(iris$Species),
                 selected = "setosa"),
    selectizeInput(inputId = ns("letters"),
                   label = "letters",
                   choices = c(letters[1:3]),
                   selected = letters[1])
  )
}

choice_server <- function(id, rv) {
  moduleServer(id, function(input, output, session) {
    # Whenever the choice changes, the value inside rv is set
    observeEvent(input$species, {
      rv$species <- input$species
    })
    
    observeEvent(input$letters, {
      rv$letters <- input$letters
    })
    
  })
}


# function ----------------

species_observer <- function(source, letter_source){
  others <- setdiff(c('sp1-species','sp2-species'), source)
  glue("
 observeEvent(input[['{source}']],{{

    # update species
    updateRadioButtons(session,
                      '{others[1]}',
                       selected = input[['{source}']])
  }})")
}

species_observer2 <- function(source){

  letter_source <- paste0(str_extract(source, "[^-]*"), "-letters")

  glue("
 observeEvent(input[['{source}']],{{

    # update letters
    if (input[['{source}']] == 'setosa'){

      updateSelectizeInput(session,
                           '{letter_source}',
                           choices = letters[1:3],
                           selected = letters[1])

    } else{

      updateSelectizeInput(session,
                           '{letter_source}',
                           choices = letters[4:6],
                           selected = letters[4])

    }
  }})")
}


# app -------------
ui <- dashboardPage(
  dashboardHeader(title = "test"),
  dashboardSidebar(
    
    sidebarMenu(id = "tabs",
                
                # Introduction -----------------------------------------------------------
                menuItem("tab1", tabName = "tab1"),
                conditionalPanel("input.tabs == 'tab1'",
                                 choice_ui("sp1")
                ),
                
                # Current applications -----------------------------------------------------------
                menuItem("tab2", tabName = "tab2"),
                conditionalPanel("input.tabs == 'tab2'",
                                 choice_ui("sp2")
                )
    )
  ),
  dashboardBody(
    "Blank."
  )
)

server <- function(input, output, session) {
  
  # reactive values ----------
  rv <- reactiveValues()
  
  # update species and letters based on species ----------
  # this works by itself
  walk(paste0("sp", 1:2, "-species"),
       ~eval(parse_expr(species_observer(.x))))
  
  # this causes an error - Warning: Error in validate_session_object: object 'session' not found
  walk(paste0("sp", 1:2, "-species"),
       ~eval(parse_expr(species_observer2(.x))))
  
  # a version using walk2 also causes the same error

  
  # synchronise letters -----------
  observe({
    updateSelectizeInput(session,
                         "sp1-letters",
                         selected = input[["sp2-letters"]])
  })
  
  observe({
    updateSelectizeInput(session,
                         "sp2-letters",
                         selected = input[["sp1-letters"]])
  })
  
  
  # module servers ----
  choice_server("sp1", rv = rv)
  choice_server("sp2", rv = rv)
  
}

shinyApp(ui, server)

Do you know what the issue is?

This version works fine. It runs on modules, but it doesn't use a function for the observer.

library(shinydashboard)
library(shiny)
library(glue)
library(rlang)
library(tidyverse)

# module --------------
# Choice of variables
choice_ui <- function(id) {
  ns <- NS(id)
  tagList(
    radioButtons(ns("species"), 
                 label = "species", 
                 choices = unique(iris$Species),
                 selected = "setosa"),
    selectizeInput(inputId = ns("letters"),
                   label = "letters",
                   choices = c(letters[1:3]),
                   selected = letters[1])
  )
}

choice_server <- function(id, rv) {
  moduleServer(id, function(input, output, session) {
    # Whenever the choice changes, the value inside rv is set
    observeEvent(input$species, {
      rv$species <- input$species
    })
    
    observeEvent(input$letters, {
      rv$letters <- input$letters
    })
    
  })
}

# app -------------
ui <- dashboardPage(
  dashboardHeader(title = "test"),
  dashboardSidebar(
    
    sidebarMenu(id = "tabs",
                
                # Introduction -----------------------------------------------------------
                menuItem("tab1", tabName = "tab1"),
                conditionalPanel("input.tabs == 'tab1'",
                                 choice_ui("sp1")
                ),
                
                # Current applications -----------------------------------------------------------
                menuItem("tab2", tabName = "tab2"),
                conditionalPanel("input.tabs == 'tab2'",
                                 choice_ui("sp2")
                )
                
    )
  ),
  dashboardBody(
    "Blank."
  )
)

server <- function(input, output, session) {
  
  # reactive values ----------
  rv <- reactiveValues()
  
  # update species and letters based on species ----------
  observeEvent(input[['sp1-species']],{
    updateRadioButtons(session,
                       'sp2-species',
                       selected = input[['sp1-species']])
    
    # update letters
    if (input[['sp1-species']] == 'setosa'){
      
      updateSelectizeInput(session,
                           'sp1-letters',
                           choices = letters[1:3],
                           selected = letters[1])
      
    } else{
      
      updateSelectizeInput(session,
                           'sp1-letters',
                           choices = letters[4:6],
                           selected = letters[4])
    }
  })
  
  observeEvent(input[['sp2-species']],{
    updateRadioButtons(session,
                       'sp1-species',
                       selected = input[['sp2-species']])
    
    # update letters
    if (input[['sp2-species']] == 'setosa'){
      
      updateSelectizeInput(session,
                           'sp2-letters',
                           choices = letters[1:3],
                           selected = letters[1])
      
    } else{
      
      updateSelectizeInput(session,
                           'sp2-letters',
                           choices = letters[4:6],
                           selected = letters[4])
    }
  })
  

  # synchronise letters -----------
  observe({
    updateSelectizeInput(session,
                         "sp1-letters",
                         selected = input[["sp2-letters"]])
  })
  
  observe({
    updateSelectizeInput(session,
                         "sp2-letters",
                         selected = input[["sp1-letters"]])
  })
  
  # module servers -------
  choice_server("sp1", rv = rv)
  choice_server("sp2", rv = rv)
  
}

shinyApp(ui, server)
5

Hi williaml, I'm very happy to be able to help you.
In this instance its one of those classic glue gotchas.
Because of course glue wants to use curly braces to denote what variables to evaluate when string building, actual curlies need to be doubled up to signal that they should be interpreted as single literal curly braces. It seems then the curly braces required by the if else logic in species_observer2 tripped you up in this way.

species_observer2 <- function(source){
  letter_source <- paste0(str_extract(source, "[^-]*"), "-letters")
  
  glue("
 observeEvent(input[['{source}']],{{

    # update letters
    if (input[['{source}']] == 'setosa'){{

      updateSelectizeInput(session,
                           '{letter_source}',
                           choices = letters[1:3],
                           selected = letters[1])

    }} else{{

      updateSelectizeInput(session,
                           '{letter_source}',
                           choices = letters[4:6],
                           selected = letters[4])
    }}
  }})")
}
1 Like
6

Excellent. Thanks again for your help on this and the explanation.

7

This topic was automatically closed 7 days after the last reply. New replies are no longer allowed.

If you have a query related to it or one of the replies, start a new topic and refer back with a link.