How to Store the Returned Value from a Shiny Module in Reactivevalues

R Shiny: How to Save Returned Value from a Module?

I somehow solved it by doing this:

Module:

custSliderGroupInput <- function(id,slider1Name,slider2Name){
    ns <- NS(id)
    tagList(sliderInput(ns("slider1"),slider1Name,1,100,50),
            sliderInput(ns("slider2"),slider2Name,1,20,10))
}

custSliderGroup <- function(input,output,session){
    rv <- input$slider1 + input$slider2
    return(rv)
}

App

ui <- fluidPage(
        custSliderGroupInput("myslider","A","B"),
        textOutput("text")
    )

server <- function(input, output,session){
    output$text <- renderText({
        callModule(custSliderGroup,"myslider")
    })
}

shinyApp(ui = ui, server = server)

I don't know why, but it seems like using functionalities such as reactive() or observeEvent() makes the module environment too complicated and does more harm than good. It just works by simplifying the codes. If anyone knows how this theoretically works or doesn't work please post your answer!

Thanks a lot!

How to return a reactive dataframe from within a shiny module that depends on a button click?

Try this

library(shiny)
library(dplyr)

df_agg_orig <- data.frame(proj_1 = c(2,3))

modGrowthInput <- function(id) {
  ns <- NS(id)
  tagList(
    numericInput(ns("first"),label = "Assumption",value = 10),
  )
}

modGrowthServer <- function(id) {
  moduleServer(id, function(input, output, session) {
    list(
      first = reactive({input$first})
    )
  })
}

modButtonUI <- function(id,lbl = "Recalculate"){
  ns <- NS(id)
  actionButton(inputId = ns("btn"),label = lbl)#,style = "pill",color = "primary",no_outline = T,size = "xs"
}

modButtonServer <- function(id){
  moduleServer(id, function(input, output, session) {
    reactive({input$btn})
  })
}

modApplyAssumpServer <- function(id,btnGrowth, df_agg, val){
  moduleServer(id, function(input, output, session) {
    stopifnot(is.reactive(btnGrowth))
    stopifnot(is.reactive(df_agg))
    
    modvals <- eventReactive(btnGrowth(), {
      print("Looping problem...")
      #print(btnGrowth())
      df_agg() %>% mutate(proj_1 = proj_1*val )
    })
    return(modvals())
  })
}

#### Test App
GrowthInputApp <- function() {
  
  ui <- fluidPage(
    sidebarPanel(modGrowthInput("tst"),modButtonUI("tstGrowth")),
    mainPanel(fluidRow( splitLayout( DT::DTOutput("no_module"),DT::DTOutput("module_tbl")))))
  
  server <- function(input, output, session) {
    
    btnGrowth <- modButtonServer("tstGrowth")
    case_vals <- modGrowthServer("tst")
    observe({ print(case_vals$first())})
    df_agg <- reactiveValues(df_wide = df_agg_orig)
    
    #Outside of module test exhibiting expected/desired behavior (at least if the looping issue would let it do so :)
    observeEvent(btnGrowth(),{
      df_agg$df_wide$proj_1 <- round(df_agg$df_wide*case_vals$first(),2)
    })
    
    mydf <- eventReactive(c(btnGrowth(),case_vals$first()), {
      modApplyAssumpServer("tst", btnGrowth, reactive({df_agg$df_wide}), case_vals$first() )
    })
    #observe({print(btnGrowth())})
    output$no_module <- renderDT({DT::datatable(rownames = F,df_agg$df_wide,caption = "Not Updated Within Module")})
    
    output$module_tbl <- renderDT({DT::datatable(rownames = F, mydf() ,caption = "Table Returned From Module")} )
    
    ###  using original data so no change after first click 
    #output$module_tbl <- renderDT({DT::datatable(rownames = F, modApplyAssumpServer("tst", btnGrowth, reactive({df_agg_orig}), case_vals$first() ),caption = "Table Returned From Module")}
    #)
  }
  
  shinyApp(ui, server)  
  
}
runApp(GrowthInputApp())

Access the returned values of dynamically created Shiny modules

Here is a solution that uses insertUI. It has the advantage that existing UI elements stay the same (no resetting of the previous modules) and only new modules are added. To determine where the UI is added, define a tags$div(id = "tag_that_determines_the_position") in the UI function. Then, insertUI takes this as an argument. Additionally, I've changed a few things:

• simplified the code for the module server function, you basically only need a reactive
• use of the new module interface introduced with shiny 1.5.0
• use a bit simpler reactive data structure (less nesting)

library(shiny)
library(stringr)

gen_r_8_formUI <- function(id){
  
  ns <- NS(id)
  
  tagList(fluidRow(column(width = 4, selectInput(ns("slt_forename"), 'forename', choices = unique(c("john", "paul", "george", "ringo")))),
                   column(width = 4, selectInput(ns("slt_surname") , 'surname' , choices = unique(c("lennon", "mccartney", "harrison", "starr"))))))
}

gen_r_8_form <- function(id){
  moduleServer(
    id,
    function(input, output, session) {
      select_values_all <- reactive({tibble(forename  = input$slt_forename,
                                            surname  = input$slt_surname)})
      
      return(list(select_values_all = reactive({select_values_all()})))
    }
  )
}

ui <- fluidPage(
  column(width = 2, actionButton("btn_gen_r_8_form", "GEN R 8 a FORM")),
  column(width = 6, tags$div(id = "add_UI_here")),
  column(width = 4, tableOutput("all_form_values_table")))

server <- function(input, output) {
  gen_forms                    <- reactiveValues()
  current_id <- 1
  
  observeEvent(input$btn_gen_r_8_form, {
    x_id <- paste0("module_", current_id)
    
    gen_forms[[x_id]] <- gen_r_8_form(id = x_id)
    
    insertUI(selector = "#add_UI_here",
             ui = gen_r_8_formUI(x_id))
    
    current_id <<- current_id + 1
  })
  
  
  all_form_values_rctv <- reactive({
    res <- lapply(reactiveValuesToList(gen_forms), function(current_module_output) {
      current_module_output$select_values_all()
    })
    
    # prevent to show an error message when the first module is added
    if (length(res) != 0 && !is.null(res[[1]]$forename)) {
      dplyr::bind_rows(res)
    } else {
      NULL
    }
    
  })
  
  output$all_form_values_table <- renderTable({
    all_form_values_rctv()
  })
}

shinyApp(ui = ui, server = server)

How to access reactive value in parent module?

You can access with value(). I would recommend to change your mod_server_btn to the one shown below, and notice the call in server. EDIT: updated for multiple variables. Try this

library(shiny)
mod_ui_btn <-  function(id, label = "ui1UI") {
  ns <- NS(id)
  shinyUI(fluidPage(
    actionButton(ns("confirm"), "Submit", class='btn-primary'),
    actionButton(ns("confirm2"), "Submit2", class='btn-primary')
  ))
}

mod_server_btn <- function(id) {
  moduleServer(id, function(input, output, session) {
    return(
      list(
        cond = reactive(input$confirm),
        cond2 = reactive(input$confirm2)
      )
    )  
    
  })
}

ui =fluidPage(
  mod_ui_btn("test"),
  verbatimTextOutput("example"),
  verbatimTextOutput("example2")
)

server=shinyServer(function(input, output, session) {   
  # value <- callModule(mod_server_btn,"test")  
  value <- mod_server_btn("test")
  output$example <- renderPrint(value$cond())
  output$example2 <- renderPrint(value$cond2())
  
  observe({
    print(value$cond())  #this is how I usually catch reactives - by their name
    print(value$cond2())
  })
})

shinyApp(ui=ui,server=server)

shiny module inside module loosing reactive value

In your filterServer function you have to use session$ns("var") instead of NS(id, "var"). The former will include enclosing namespace whereas the later will only include current namespace. I added two messages that will show in the console what I mean.

filterServer <- function(id, df) {
  moduleServer(id, function(input, output, session) {
    message("session namespace: ", session$ns("test"))
    message("raw namespace: ", NS(id, "test"))
    vars <- reactive(names(df))
    
    output$controls <- renderUI({
      map(vars(), function(var) make_ui(df[[var]], session$ns(var), var))
    })
    
    reactive({
      each_var <- map(vars(), function(var) filter_var(df[[var]], input[[var]]))
      reduce(each_var, `&`)
    })
  })
}

Rbind data returned by a shiny module to a reactiveValues object

tl;dr

Replace return(values2$new_row) by return(reactive({values2$new_row})) in your module function and x by x() in the observeEvent inside your server side.

You can a working example here :

library(shiny)

options(shiny.error=recover)

data <- data.frame(x = 1:10)

moduleUI <- function(id) {
  ns <- NS(id)
  actionButton(ns("append"), "Append row")
}

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

  values2 <- reactiveValues(new_row = NULL)

  observeEvent(input$append, {

    values2$new_row <- data.frame(x = sample(1:100, 1))
  })

  return(reactive({values2$new_row}))
}

ui <- fluidPage(
  moduleUI("mod"),
  tableOutput("table")
)

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

  values <- reactiveValues(data = data)

  x <- callModule(module, "mod")

  observeEvent(x(), {
    values$data <- rbind(values$data, x())
  })

  output$table <- renderTable({
    values$data
  })
}

shinyApp(ui, server)

---

If you want to understand how I got to the above, see the following:

When running your code, we get the following message:

Warning: Error in .getReactiveEnvironment()$currentContext: Operation not allowed without an active reactive context. (You tried to do something that can only be done from inside a reactive expression or observer.)
  61: stop
  60: .getReactiveEnvironment()$currentContext
  59: .subset2(x, "impl")$get
  58: $.reactivevalues
  56: module [#10]
  51: callModule
  50: server [#5]
Error in .getReactiveEnvironment()$currentContext() : 
  Operation not allowed without an active reactive context. (You tried to do something that can only be done from inside a reactive expression or observer.)

This says that we are having problems in line 5 of the server function (the line with x <- callModule(module, "mod")) and line 10 of the module function (the line with return(values2$new_row)).

Putting browser() in line 9 of the module function and running the code again makes the browser stops right before return(values2$new_row). Running this piece of code in browser yields the error message:

Error in .getReactiveEnvironment()$currentContext() : 
  Operation not allowed without an active reactive context. (You tried to do something that can only be done from inside a reactive expression or observer.)

This means that whatever you are returning should be inside a reactive or part of an observe function. So, we write return(reactive({values2$new_row})) and hit enter to see that this works (i.e. it doesn't give any error and our debugger goes to line 10 of the module function).

Typing Q and hitting enter to leave browser mode and get back to our code. Put the correct code return(reactive({values2$new_row})).

But that's not all. Because our function is now returning a reactive value, we have to call x using x(). So, changing this in the observeEvent bit yields:

  observeEvent(x(), {
    values$data <- rbind(values$data, x())
  })

How does one retrieve values from a shiny module that are created iteratively based on user input?

Here is a very hacky way to do it. If someone comes up with a better solution I'd be very happy! You basically store the unevaluated reactives returned by the module in a reactiveValues object and then evaluate every element of reactiveValues in a new reactive. You could probably also use an ordinary list instead of reactiveValues, but then you would need to use <<- to assign the values inside the observeEvent which can lead to problems.

server <- function(input, output, session) {
  mod_results <- reactiveValues()
  vec <- reactive({
    switch(input$items, Animals = Animals, Vehicles = Vehicles)
  })
  
  output$levels_fills <- renderUI(
    purrr::map2(vec(), seq_along(vec()), function(level, n) {
      mod_fill_def_ui(glue("fill_{level}"), level, length(vec()), n)
    })
  )
  
  ### How do I use `mod_fill_def_server()` iteratively to retrieve the hex codes?
  observeEvent(vec(), {
    purrr::map(vec(), function(level) {
      mod_results[[glue("fill_{level}")]] <- mod_fill_def_server(id = glue("fill_{level}"))
    })
  })
  
  hex <- reactive({
    lapply(reactiveValuesToList(mod_results), function(current_module_output) {
      current_module_output()
    })
  })
  
  output$fill_hex <- renderPrint({
    hex()
  })
}

However, if your module only contains the colourInput, you don't need a module but could use the colourInput directly:

server <- function(input, output, session) {
  vec <- reactive({
    switch(input$items, Animals = Animals, Vehicles = Vehicles)
  })
  
  output$levels_fills <- renderUI(
    purrr::map2(vec(), seq_along(vec()), function(level, n) {
      colourInput(inputId = glue("fill_{level}"),
                  label = glue("Colour for {level}"),
                  value = hue_pal()(length(vec()))[n])
    })
  )
  
  hex <- reactive({
    purrr::map(vec(), function(level) {
      input[[glue("fill_{level}")]]
    })
  })
  
  output$fill_hex <- renderPrint({
    hex()
  })
}

R Shiny: How can I return reactive values from a shiny module to the master server function?

As said in the comment, you can pass the values as return values in the corresponding server functions. There is a working example below. I left out the firstUI, firstServer and removeFirstUI implementations since they are irrelevant for your problem.

library(shiny)

addRmBtnUI <- function(id) {
    ns <- NS(id)

    tags$div(
    actionButton(inputId = ns('insertParamBtn'), label = "Add"),
    actionButton(ns('removeParamBtn'), label = "Remove"),
    hr(),
    tags$div(id = ns('placeholder'))
  )
}

addRmBtnServer <- function(input, output, session, moduleToReplicate, ...) {
  ns = session$ns

  params <- reactiveValues(btn = 0)

  observeEvent(input$insertParamBtn, {
    params$btn <- params$btn + 1

    callModule(moduleToReplicate$server, id = params$btn, ...)
    insertUI(
      selector = paste0('#', ns('placeholder')),
      ui = moduleToReplicate$ui(ns(params$btn))
    )
  })

  observeEvent(input$removeParamBtn, {
    moduleToReplicate$remover(ns(params$btn))
    params$btn <- params$btn - 1
  })

  return(reactive({params$btn}))
}

ui <- fluidPage(
  addRmBtnUI("addRm"),
  verbatimTextOutput("view", placeholder = TRUE)
)

server <- function(input, output, session) {
  a <- reactive({input$a})

  pars <- callModule(
    addRmBtnServer, id = "addRm",
    moduleToReplicate = list(
      ui = function(...){},
      server = function(...){},
      remover = function(...){}
    )
  )
  output$view <- renderText({ pars() })
}

shinyApp(ui = ui, server = server)

---

Related Topics