Updating private but not UI in reactive element - r

I have an R6 class that I am using to organize my shiny application. Essentially, I want to connect different R6 classes for an experimental interface I am creating and want to reuse my code. As a simplified working example, see the code below.
library(R6)
library(stringi)
library(shiny)
df <- data.frame(dp = c("dp1", "dp2", "dp3"), desc = c("problem 1", "problem 2", "problem 3"))
app <- R6::R6Class(classname = "App",
private = list(
#unique string id
..id = stringi::stri_rand_strings(1, 18),
#the data to be iterated through
..df = df,
#counter to update text
..counter = 1,
#initiating the dp and desc
..dp = 'dp1',
..desc = 'problem 1',
#the underlying server, to be created like a normal server
.server = function(input, output, session){
output$text <- renderText({
private$..desc
})
observeEvent(input$button, {
private$..counter <- private$..counter + 1
self$update_private()
#check the private content since the print is not updating
print(private$..counter)
print(private$..dp)
print(private$..desc)
})
}
),
public = list(
#create names for ui elements
button = NULL,
text = NULL,
initialize = function(){
self$button <- self$get_id("button")
self$text <- self$get_id("text")
self$update_private()
},
#gives ui outputs unique names tied to the user's id
get_id = function(name, ns = NS(NULL)){
ns <- NS(ns(private$..id))
id <- ns(name)
return(id)
},
#automatically updates the private field based on the counter
update_private = function(){
if(private$..counter == 1){
private$..dp <- "dp1"
} else if(private$..counter == 2){
private$..dp <- "dp2"
} else{
private$..dp <- "dp3"
}
private$..desc <- private$..df[private$..df$dp == private$..dp, "desc"]
},
ui = function(){
fluidPage(
h1("An Example"),
mainPanel(
textOutput(self$text)),
sidebarPanel(
shiny::actionButton(inputId = self$button,
label = 'Update!',
width = '100%'
))
)
},#end ui
server = function(input, output, session){
callModule(module = private$.server, id = private$..id)
}
)
)
test <- app$new()
ui <- test$ui()
server <- function(input, output, session) {
test$server()
}
shinyApp(ui = ui, server = server)
What I want: when someone clicks the action button, the reactive ui will update and the desired text from the data frame will be sliced and displayed.
What I am getting: the internal private data fields are updating but the reactive ui elements are not.
Any ideas what could be causing this or a workaround? I thought about externally trying to use the observe event and then reinitiating the class with a new counter number. But I also can't seem to figure out that option either.
Appreciate your help!

For anyone that comes across this problem... I figured out that even though the private is updating, and even though render is technically a reactive environment, you need to have your data stored publically in a reactive field.
library(R6)
library(stringi)
library(shiny)
df <- data.frame(dp = c("dp1", "dp2", "dp3"), desc = c("problem 1", "problem 2", "problem 3"))
app <- R6::R6Class(classname = "App",
private = list(
#unique string id
..id = stringi::stri_rand_strings(1, 18),
#the data to be iterated through
..df = df,
#counter to update text
..counter = 0,
#initiating the dp and desc
..dp = NA,
..desc = NA,
#the underlying server, to be created like a normal server
.server = function(input, output, session){
output$text <- renderText({
self$desc$text
})
observeEvent(input$button, {
private$..counter <- private$..counter + 1
self$update_private()
self$desc$text <- private$..desc
#check the private content since the print is not updating
print(private$..counter)
print(private$..dp)
print(private$..desc)
})
}
),
active = list(
.counter = function(value){
if(missing(value)){
private$..counter
}else{
private$..counter <- value
}
}
),
public = list(
#create names for ui elements
button = NULL,
text = NULL,
#Need this to update the text***************
desc = reactiveValues(text = NA),
initialize = function(counter = self$.counter){
self$.counter <- counter
self$button <- self$get_id("button")
self$text <- self$get_id("text")
self$update_private()
self$desc$text <- private$..desc
},
#gives ui outputs unique names tied to the user's id
get_id = function(name, ns = NS(NULL)){
ns <- NS(ns(private$..id))
id <- ns(name)
return(id)
},
#automatically updates the private field based on the counter
update_private = function(){
if(private$..counter == 1){
private$..dp <- "dp1"
} else if(private$..counter == 2){
private$..dp <- "dp2"
} else{
private$..dp <- "dp3"
}
private$..desc <- private$..df[private$..df$dp == private$..dp, "desc"]
},
ui = function(){
fluidPage(
h1("An Example"),
mainPanel(
textOutput(self$text)),
sidebarPanel(
shiny::actionButton(inputId = self$button,
label = 'Update!',
width = '100%'
))
)
},#end ui
server = function(input, output, session){
counter <- reactiveVal(private$..counter)
callModule(module = private$.server, id = private$..id)
}
)
)
test <- app$new(counter = 1)
ui <- test$ui()
server <- function(input, output, session) {
test$server()
}
shinyApp(ui = ui, server = server)

Related

Communication between modules and looping through values to create several modules

Goal
I have five expectations:
Solution using modules
Communication between modules
Dynamic creation of modules
local storage using shinyStore
Export result in dataframe
What has worked so far
This is a continuation of the following question.
I have a Shiny app that currently has two modules, but I have had issues with both of them communicating. The first module Selects any number of species within a Species pool (SpeciesSelect), this module is in the file R/SpeciesSelect.R within my working directory with the following code.
SpeciesSelect_UI <- function(id, SpeciesList){
ns <- NS(id)
tagList(
shiny::selectizeInput(inputId = ns("SpeciesNames"), label = "SpeciesName",
choices = SpeciesList,
multiple = T)
)
}
SpeciesSelect_Server <- function(id){
moduleServer(id, function(input, output, session) {
# return the reactive here
return(reactive({input$SpeciesNames}))
})
}
And the second module (SpeciesCount) would use those species in order to select how you sample them, and in some cases to count them when the method is equal to pinpoint. This is stored in R/SpeciesCount.R and the code is as follows:
SpeciesCount_UI <- function(id, Species){
ns <- NS(id)
tagList(
shinyMobile::f7Card(
f7Flex(
textOutput(ns("SpeciesAgain")),
uiOutput(ns("Sampling_type_ui")),
uiOutput(ns("SpeciesCount"))
)
)
)
}
SpeciesCount_Server <- function(id, Species){
moduleServer(id, function(input, output, session) {
output$SpeciesAgain <- renderText({Species})
ns <- session$ns
output$Sampling_type_ui <- renderUI({
#req(input$SpeciesName)
req(Species)
f7Select(inputId = ns("Sampling_type"),
label = "Sampling type",
choices = c("5m circle", "15m circle", "Pin-point"))
})
output$SpeciesCount <- renderUI({
if (req(input$Sampling_type) == "Pin-point") {
shinyMobile::f7Stepper(inputId = ns("Species1"), label = "Species count", min = 1, max = 1000, step = 1, value = 1)
}
})
})
}
Each of the modules is working well on its own as shown in the following example:
library(shiny)
library(shinyMobile)
library(shinyStore)
source("R/SpeciesCount.R")
source("R/SpeciesSelect.R")
SpeciesList <- c("Species1", "Species2", "Species3", "Species4", "Species5")
ui = f7Page(
title = "Show navbar",
f7SingleLayout(
navbar = f7Navbar("Hide/Show navbar"),
f7Button(inputId = "toggle", "Toggle navbar", color = "red"),
SpeciesSelect_UI(id = "SpeciesList", SpeciesList = SpeciesList),
lapply(seq_along(SpeciesList), function(i) {
SpeciesCount_UI(id = i, Species = SpeciesList[i])
})
)
)
server = function(input, output, session) {
lapply(seq_along(SpeciesList), function(i) {
SpeciesCount_Server(id = i, Species = SpeciesList[i])
})
observeEvent(input$toggle, {
updateF7Navbar()
})
}
shinyApp(ui, server)
I have 4 issues that are not working well, first, the communication between modules, and then looping through the results of the first module to get several of the second module, the localStorage issue, and finally exporting it to a dataframe
Communication between modules and dynamic UI generation
In order to isolate both issues, for the communication problem, I selected only one species and took out the lapply function to see if I can get the SpeciesCount to recognise the output of the SpeciesSelect_Server and incorporate it into the SpeciesCount module, here is the code I ended up with:
library(shiny)
library(shinyMobile)
library(shinyStore)
source("R/SpeciesCount.R")
source("R/SpeciesSelect.R")
LIST <- c("Species1", "Species2", "Species3", "Species4", "Species5")
ui = f7Page(
title = "Show navbar",
f7SingleLayout(
navbar = f7Navbar("Hide/Show navbar"),
f7Button(inputId = "toggle", "Toggle navbar", color = "red"),
SpeciesSelect_UI(id = "SpeciesList", SpeciesList = LIST),
SpeciesCount_UI(id = "SpeciesCount", Species = SpeciesSelected())
)
)
server = function(input, output, session) {
SpeciesSelected <- SpeciesSelect_Server(id = "SpeciesList")
SpeciesCount_Server(id = "SpeciesCount", Species = SpeciesSelected())
observeEvent(input$toggle, {
updateF7Navbar()
})
}
shinyApp(ui, server)
But the results of the SpeciesSelect module are not generating any UI in the SpeciesCount module
Adding the LocalStorage issue
This app is going to be used in the field, that means, that at time we might get connectivity issues, I have issues at storing the values of the Species Select Module, then for sure I will have issues with the next module this is the shiny app I am using
library(shiny)
library(shinyMobile)
library(shinyStore)
source("R/SpeciesCount.R")
source("R/SpeciesSelect.R")
SpeciesList <- c("Species1", "Species2", "Species3", "Species4", "Species5")
ui = f7Page(
title = "Show navbar",
f7SingleLayout(
navbar = f7Navbar("Hide/Show navbar"),
f7Button(inputId = "toggle", "Toggle navbar", color = "red"),
SpeciesSelect_UI(id = "SpeciesList", SpeciesList = SpeciesList),
lapply(seq_along(SpeciesList), function(i) {
SpeciesCount_UI(id = i, Species = SpeciesList[i])
})
)
)
server = function(input, output, session) {
lapply(seq_along(SpeciesList), function(i) {
SpeciesCount_Server(id = i, Species = SpeciesList[i])
})
observeEvent(input$toggle, {
updateF7Navbar()
})
}
shinyApp(ui, server)
And I modified the species select for that also
SpeciesSelect_UI <- function(id, SpeciesList){
ns <- NS(id)
tagList(
shiny::selectizeInput(inputId = ns("SpeciesNames"), label = "SpeciesName",
choices = SpeciesList,
multiple = T)
)
}
SpeciesSelect_Server <- function(id){
moduleServer(id, function(input, output, session) {
ns <- session$ns
# return the reactive here
observeEvent(input$save, {
updateStore(session, name = ns("SpeciesNames"), input$SpeciesNames)
}, ignoreInit = TRUE)
observeEvent(input$clear, {
# clear current user inputs:
updateTextInput(session, inputId = ns("SpeciesNames"), value = "")
# clear shinyStore:
updateStore(session, name = ns("SpeciesNames"), value = "")
}, ignoreInit = TRUE)
return(reactive({ns(input$SpeciesNames)}))
})
}
But nothing gets stored. Maybe creating a module for shiny store is needed?
Export as a dataframe
This one is tied two point 2:
So lets say I am in the following input set:
The idea would be to generate a reactive that has the following that frame, that I can then export as a CSV file. I think I can handle the export, but I am unsure on how to generate the data.frame from the dynamic UI:
data.frame(Species = c("Species1", "Species2", "Species3"), Method = c("Pin-point","5m circle", "15m circle"), abundance = c(5, 1, 1))
Your first module is probably already silently returning the reactive but for clarity you can make it explicit. In you first module, return a reactive:
SpeciesSelect_Server <- function(id){
moduleServer(id, function(input, output, session) {
# return the reactive here
return(reactive({input$SpeciesNames}))
})
}
Now call the module AND assign its output a name where you'd like to use it (in another module or in your app server), like this:
selected_species <- SpeciesSelect_Server(id = "SpeciesList")
Now selected_species can be called, observed, etc with:
selected_species()

Use Shiny Reactive from server as UI Input

I am struggling to use the result of a reactive function as input for the UI.
Currently, I am mostly using renderUI which decreased performance as the app got more complex.
Using
DetailsList(items = filtered_Accounts(), columns = columns.top.accounts, checkboxVisibility = 2)
in the UI function did not work because it could not access the reactive?
Below is a shortened example with only two filters:
UI:
# Column Definitions for Table -----------
columns.top.accounts <- tibble(
fieldName = c("text", "occupation", "Gender", "age.floor", "Nationality","n_friends_formatted", "n_followers_formatted"),
name = c("Name", "Occupation", "Gender", "Age" , "Nationality" ,"# of Friends", "# of Followers")
)
# UI - Filters -----------
filters.descriptive <- Stack(
tokens = list(childrenGap = 10),
Label("Filter by Twitter user", className = "my_class"),
NormalPeoplePicker.shinyInput(
"selectedAccounts",
class = "my_class",
options = df.Account.Info
)
),
Slider.shinyInput("slider",
value = 0, min = 0, max = 600000, step = 1000,
label = "Minimum number of friends",
valueFormat = JS("function(x) { return x}"),
snapToStep = TRUE
)
)
# UI-Function --------------
ui <- function(input, output, session) {
filters.descriptive,
uiOutput("table.top.accounts")
}
Server:
server <- function(input, output, session) {
# ---- Reactive --------------
filtered_Accounts <- reactive({
req(input$slider)
selectedAccounts <- (
if (length(input$selectedAccounts) > 0) input$selectedAccounts
else df.Account.Info$key
)
filtered_Accounts <- df.Account.Info %>%
filter(
key %in% selectedAccounts,
n_friends >= input$slider
)
}) %>% debounce(750)
# Outputs Descriptive ------------------
output$table.top.accounts <- renderUI({
items_list <- if(nrow(filtered_Accounts()) > 0){
DetailsList(items = filtered_Accounts(), columns = columns.top.accounts, checkboxVisibility = 2)
} else {
p("No matching transactions.")
}
})
}
shinyApp(ui, server)
I believe I have to use observe ({}) here but I was not able to apply it to my case successfully.
Any help is much appreciated.

R Shiny - Saving results of dynamically created modules

I encountered the following problem that I have tried to summarize in this minimal reproducible example.
The app should be able to dynamically create modules and render the UI of the module - obj_UI in my example - in a tab of the tabsetpanel objTP. Each of this modules should render a R6 object of type objR6. I would like to save the resulting R6 objects into a reactiveValues variable called objCollection and display it in the verbatimTextOutput called displayValues.
When clicking on the input$addObject button, I get the error message "Error in <-: cannot add bindings to a locked environment". I believe the problem lies in the observeEvent at the very end of the example, but cannot figure what it is.
Any help would be much appreciated!
library(shiny)
library(R6)
# Simple R6 object
objR6 <- R6::R6Class(
"objR6",
public = list(
identifier = NULL,
selected_value = NULL,
initialize = function(identifier) {
self$identifier <- identifier
}
)
)
# Module Ui
obj_UI <- function(id) {
tagList(
selectInput(NS(id, "value"), "Chose Value", letters)
)
}
# Module Server
obj_Server <- function(id) {
moduleServer(id, function(input, output, session) {
obj <- reactiveVal(objR6$new(id))
observeEvent(input$value, {
newObj <- obj()$clone()
newObj$selectec_value <- input$value
obj(newObj)
})
return(reactive(obj()))
})
}
# Shiny App
ui <- fluidPage(
fluidPage(
selectInput("objSelection", "Select Object",
choices = "",
selectize = FALSE,
size = 10),
actionButton("addObject", "Add Object"),
actionButton("rmvObject", "Remove Object"),
tabsetPanel(id = "objTP"),
verbatimTextOutput("displayValues")
)
)
server <- function(input, output, session) {
objCount <- reactiveVal(0)
objCollection <- reactiveValues(objects = list())
# Reaction on action button "addObject"
observeEvent(input$addObject, {
# Add another item
objCount(objCount() + 1)
newObjName <- paste0("Object_", objCount())
updateSelectInput(session, "objSelection", choices = c(paste0("Object_", 1:objCount())))
# Append the object tabset panel
appendTab("objTP", tabPanel(newObjName, obj_UI(newObjName)), select = TRUE)
})
# Reaction on action button "rmvObject"
observeEvent(input$rmvObject, {
delObjName <- paste0("Object_", objCount())
objCount(objCount() - 1)
updateSelectInput(session, "objSelection", choices = c(paste0("Object_", 1:objCount())))
removeTab("objTP", target = delObjName)
})
# Implement the server side of module
observeEvent(objCount(), {
if (objCount() > 0) {
for (i in 1:objCount()) {
identifier <- paste0("Object_", i)
observeEvent(obj_Server(identifier), {
objCollection$objects[[identifier]] <- obj_Server(identifier)
})
}
}
# Ouput the selected values
output$displayValues <- renderPrint({
reactiveValuesToList(objCollection)
})
})
}
shinyApp(ui, server)
The following minimal reproducible example is an answer to the problem above. In comparison to the code above I corrected a typo in the server function of the module and also put the initialization of the server part in the observeEvent for the input$addObject and removed the observeEvent for objCount().
library(shiny)
library(R6)
# Simple R6 object
objR6 <- R6::R6Class(
"objR6",
public = list(
identifier = NULL,
selected_value = NULL,
initialize = function(identifier) {
self$identifier <- identifier
}
)
)
# Module Ui
obj_UI <- function(id) {
tagList(
selectInput(NS(id, "value"), "Chose Value", letters)
)
}
# Module Server
obj_Server <- function(id) {
moduleServer(id, function(input, output, session) {
obj <- reactiveVal(objR6$new(id))
observeEvent(input$value, {
newObj <- obj()$clone()
newObj$selected_value <- input$value
obj(newObj)
})
return(reactive(obj()))
})
}
# Shiny App
ui <- fluidPage(
fluidPage(
selectInput("objSelection", "Select Object",
choices = "",
selectize = FALSE,
size = 10),
actionButton("addObject", "Add Object"),
actionButton("rmvObject", "Remove Object"),
tabsetPanel(id = "objTP"),
verbatimTextOutput("displayValues")
)
)
server <- function(input, output, session) {
objCount <- reactiveVal(0)
objCollection <- reactiveValues(objects = list())
# Reaction on action button "addObject"
observeEvent(input$addObject, {
# Add another item
objCount(objCount() + 1)
newObjName <- paste0("Object_", objCount())
updateSelectInput(session, "objSelection", choices = c(paste0("Object_", 1:objCount())))
# Append the object tabset panel
appendTab("objTP", tabPanel(newObjName, obj_UI(newObjName)), select = TRUE)
# Add the server component of the module
observeEvent(obj_Server(newObjName), {
objCollection$objects[[newObjName]] <- obj_Server(newObjName)
})
})
# Reaction on action button "rmvObject"
observeEvent(input$rmvObject, {
delObjName <- paste0("Object_", objCount())
if (objCount() > 0) {
objCount(objCount() - 1)
removeTab("objTP", target = delObjName)
objCollection$objects[[delObjName]] <- NULL
if (objCount() > 0) {
updateSelectInput(session, "objSelection", choices = c(paste0("Object_", 1:objCount())))
} else {
updateSelectInput(session, "objSelection", choices = "")
}
}
})
# Ouput the selected values
output$displayValues <- renderPrint({
lapply(reactiveValuesToList(objCollection)$objects, function(i) {i()})
})
}
shinyApp(ui, server)

Access the returned values of dynamically created Shiny modules

I am looking to build a shiny app that dynamically creates modules (via callmodule) that returns a simple form. I have 2 loose ends on it that I would appreciate some guidance on please.
Firstly, when multiple forms are brought to the user (via a button click), the values on previously rendered forms revert to the default. How do I stop this behaviour so that values stay on the users selection?
And 2, how do I access and present ‘all’ the values from the selections into a single tibble that can be shown in a tableOutput?
I have put a simple example together below using observeEvent; I also tried a variation with eventReactive however I just can’t seem to access the callmodule outputs.
Thnx in advance!
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(input, output, session){
select_values <- reactiveValues(forename = NULL, surname = NULL)
observeEvent(input$slt_forename,{select_values$forename <- input$slt_forename})
observeEvent(input$slt_surname, {select_values$surname <- input$slt_surname})
select_values_all <- reactive({tibble(forename = select_values$forename, surname = select_values$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, uiOutput("all_ui_forms")),
column(width = 4, tableOutput("all_form_values_table")))
server <- function(input, output) {
rctv_uis <- reactiveValues(all_ui = list())
gen_forms <- reactiveValues(all_form_values = list())
output$all_ui_forms <- renderUI({tagList(rctv_uis$all_ui)})
output$all_form_values_table <- renderTable({all_form_values_rctv()})
observeEvent(input$btn_gen_r_8_form, {
x_id <- paste( "ns_", str_replace_all(paste(Sys.time()), "-| |:", '') , sep = '')
gen_forms$all_form_values[[x_id]] <- callModule(module = gen_r_8_form, id = x_id)
rctv_uis$all_ui[[x_id]] <- gen_r_8_formUI(id = x_id)
})
all_form_values_rctv <- reactive({
# Question - how to make a tibble with all form values?
# tibble(
# forenames = 'all gen_forms$all_form_values forenames',
# surnames = 'all gen_forms$all_form_values surnames'
# )
})
}
shinyApp(ui = ui, server = server)
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)
I think you want something like this
all_form_values_rctv <- reactive({
dplyr::bind_rows(lapply(gen_forms$all_form_values, function(x) {
x$select_values_all()
}))
})
You've collected all the model reactive elements in gen_forms$all_form_values so you iterate over them and get the reactive value and then bind all those tables together.

How to call a shiny module from a shiny module?

How do I call a shiny module from within a shiny module with passing selections from the first module?
As an example I wrote a app to show the Star Wars subjects from dplyr in a DT::data table (module StarWars). The related films from the same data set should be shown in another DT::data table in another sub tab (module Films).
I pass the table selected subject in a reactive value sw_rows_selected_rct from module StarWars to module Films but browser() statement in module Films is not passed.
# Test call of modules inside modules
library(tidyverse)
#' Shiny StarWars module
#'
ui_Films <-
function(id,
title = id,
...,
value = title,
icon = NULL) {
ns <- shiny::NS(id)
tab <- tabPanel(title,
h4("StarWars Films"),
DT::dataTableOutput(outputId = ns("Films")))
}
ui_StarWars <-
function(id,
title = id,
...,
value = title,
icon = NULL) {
ns <- shiny::NS(id)
tab <- tabPanel(title,
DT::dataTableOutput(outputId = ns("StarWars")),
tabsetPanel(ui_Films(
id = ns("Films"), title = "...by Films"
)))
}
ui <- shinyUI(navbarPage(
"Call Modules in Modules test",
ui_StarWars("StarWars", title = "StarWars")
))
Films <-
function(input,
output,
session,
sw_data,
sw_selection) {
ns <- session$ns
sw_films_rct <- observe({
req(sw_data, is.data.frame(sw_selection))
browser() # not reached!!!
sw_films_rct <-
sw_data %>% {
if (is_null(sw_selection))
.
else
filter(., name == sw_selection$name)
}
})
output$StarWarsFilms <- DT::renderDataTable({
req(is.data.frame(sw_films_rct))
DT::datatable(sw_films_rct,
selection = 'single',
options = list(pageLength = 5))
})
}
StarWars <-
function(input, output, session, sw_data) {
sw_rows_selected_rct = reactiveVal()
ns <- session$ns
sw_rows_selected_rct = observeEvent(input$StarWars_rows_selected, {
req(sw_data, input$StarWars_rows_selected != 0)
browser()
sw_data[input$StarWars_rows_selected, ]
})
md_films <- callModule(
module = Films,
id = "Films",
sw_data = sw_data,
sw_selection = sw_rows_selected_rct
)
output$StarWars <- DT::renderDataTable({
req(is.data.frame(sw_data))
DT::datatable(sw_data,
selection = 'single',
options = list(pageLength = 5))
})
}
server <- shinyServer(function(input, output, session) {
sw_data_rct = reactive({
dplyr::starwars %>% mutate(films = NULL,
vehicles = NULL,
starships = NULL)
})
md_StarWars = callModule(module = StarWars,
id = "StarWars",
sw_data = sw_data_rct())
})
# Run the application
shinyApp(ui = ui, server = server)
Your code had a few errors. Remember, observe and observeEvents don't have return values. Set the value of your reactives through the nameofReactive(newValue). Your initial goal is possible if you give the reactive to the module, not the current value of the reactive, so that it can change throughout the course of using the app. In the module, you then have to you the value of the reactive, by using () on the reactive. Oh, and your last output had the wrong name (output$Films should be correct). Here is the working app:
library(tidyverse)
#' Shiny StarWars module
#'
ui_Films <-
function(id, title = id, ..., value = title, icon = NULL) {
ns <- shiny::NS(id)
tab <- tabPanel(title,
h4("StarWars Films"),
DT::dataTableOutput(outputId = ns("Films"))
)
}
ui_StarWars <-
function(id, title = id, ..., value = title, icon = NULL) {
ns <- shiny::NS(id)
tab <- tabPanel(title,
DT::dataTableOutput(outputId = ns("StarWars")),
tabsetPanel(
ui_Films(id = ns("Films"), title = "...by Films"))
)
}
ui <- shinyUI(
navbarPage(
"Call Modules in Modules test",
ui_StarWars("StarWars", title = "StarWars")
)
)
Films <-
function(input, output, session, sw_data, sw_selection) {
ns <- session$ns
sw_films_rct <- reactiveVal()
observe({
sw_films_rct(sw_data() %>% {if(is_null(sw_selection())) . else filter(., name == sw_selection()$name)})
})
output$Films <- DT::renderDataTable({
req(is.data.frame(sw_films_rct()))
DT::datatable(sw_films_rct(),
selection = 'single',
options = list(pageLength = 5))
})
}
StarWars <-
function(input, output, session, sw_data) {
sw_rows_selected_rct= reactiveVal()
ns <- session$ns
observeEvent(input$StarWars_rows_selected, {
req(sw_data(), input$StarWars_rows_selected != 0)
sw_rows_selected_rct(sw_data()[input$StarWars_rows_selected,])
})
md_films <- callModule(module = Films, id = "Films",
sw_data= sw_data,
sw_selection= sw_rows_selected_rct)
output$StarWars <- DT::renderDataTable({
req(is.data.frame(sw_data()))
DT::datatable(sw_data(),
selection = 'single',
options = list(pageLength = 5))
})
}
server <- shinyServer(function(input, output, session) {
sw_data_rct= reactive({dplyr::starwars %>% mutate(films = NULL, vehicles = NULL, starships = NULL)})
md_StarWars= callModule(module = StarWars, id = "StarWars", sw_data = sw_data_rct)
})
# Run the application
shinyApp(ui = ui, server = server)

Resources