Related
I am trying to reuse the Filter module code provided in the Mastering Shiny book. It takes a dataframe, generate a "select" widget for each column and return a reactive that output a boolean vector. This vector can be used to filter the dataframe row-wise according to the selected data range from the widgets.
This works as intended when I simply reuse the filter module directly in a ShinyApp.
But when I try to use it from inside another module, the returned reactive outputs logical(0) where it should output a vector with length equal to row number of the input dataframe.
Here is a minimal working example based on the code from the book.
library(shiny)
library(purrr)
# Filter module from https://mastering-shiny.org/scaling-modules.html#dynamic-ui
#helper functions
make_ui <- function(x, id, var) {
if (is.numeric(x)) {
rng <- range(x, na.rm = TRUE)
sliderInput(id, var, min = rng[1], max = rng[2], value = rng)
} else if (is.factor(x)) {
levs <- levels(x)
selectInput(id, var, choices = levs, selected = levs, multiple = TRUE)
} else {
# Not supported
NULL
}
}
filter_var <- function(x, val) {
if (is.numeric(x)) {
!is.na(x) & x >= val[1] & x <= val[2]
} else if (is.factor(x)) {
x %in% val
} else {
# No control, so don't filter
TRUE
}
}
#Module
filterUI <- function(id) {
uiOutput(NS(id, "controls"))
}
filterServer <- function(id, df) {
moduleServer(id, function(input, output, session) {
vars <- reactive(names(df))
output$controls <- renderUI({
map(vars(), function(var) make_ui(df[[var]], NS(id, var), var))
})
reactive({
each_var <- map(vars(), function(var) filter_var(df[[var]], input[[var]]))
reduce(each_var, `&`)
})
})
}
#App
filterApp <- function() {
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
textOutput("n"),
filterUI("filter"),
),
mainPanel(
verbatimTextOutput("debug"),
tableOutput("table")
)
)
)
server <- function(input, output, session) {
df <- datasets::ToothGrowth[seq(1,60,5),] #subset rows from ToothGrowth
filter <- filterServer("filter", df)
output$table <- renderTable(df[filter(), , drop = FALSE])
output$n <- renderText(paste0(sum(filter()), " rows"))
output$debug <- renderPrint(filter())
}
shinyApp(ui, server)
}
filterApp() #This works !
Then a simple Module to test the filter from inside it :
filterPageUI <- function(id) {
tagList(
filterUI(NS(id, "filter"))
)
}
filterPageServer <- function(id, df) {
moduleServer(id, function(input, output, session) {
filterServer("filter", df = df)
})
}
And the ShinyApp modification to use this new module :
filterPageApp <- function() {
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
textOutput("n"),
filterPageUI("filterpage"),
),
mainPanel(
verbatimTextOutput("debug"),
tableOutput("table")
)
)
)
server <- function(input, output, session) {
#subset rows from ToothGrowth
df <- datasets::ToothGrowth[seq(1,60,5),]
filter <- filterPageServer("filterpage", df)
output$table <- renderTable(df[filter(), , drop = FALSE])
output$n <- renderText(paste0(sum(filter()), " rows"))
output$debug <- renderPrint(filter())
}
shinyApp(ui, server)
}
filterPageApp() #This does not work!
I suspect that the problem comes from namespacing, maybe inside the map/reduce logic. But I cant wrap my head around it.
Moreover, the last paragraph from the chapter says that this module should be usable elsewhere without modifications.
A big advantage of using a module here is that it wraps up a bunch of advanced Shiny programming techniques. You can use the filter module without having to understand the dynamic UI and functional programming techniques that make it work.
Any advice would be greatly appreciated. Thanks in advance !
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, `&`)
})
})
}
I am stuck about how to know whether a button inside a Shiny module is pressed. In this simplified example below, I created a module (buttonUI, buttonServer): there is a button inside this module, and my goal is to "know" (detect) this button is pressed from outside of the module.
buttonUI <- function(id) {
ns <- NS(id)
tagList(actionButton(ns("btn"), "a button label")
)}
buttonServer <- function(id, parent) {
moduleServer(id,
## Below is the module function
function(input, output, session) {
ns <- session$ns
ret <- reactiveVal(0)
observeEvent(input$btn,{
message("inner", ret())
ret(ret()+1)
})
list(n = reactive(ret))
})
}
ui <- fluidPage(
buttonUI("mod")
)
server <- function(input, output, session) {
v = buttonServer("mod")
observeEvent(v$n, {
message("outer")
})
}
shinyApp(ui, server)
I expected to see many outputs of "outer" when I clicked the button, but I do not see any.
PS: I have tried to return a single reactive value (return(ret)) instead of a list (e.g., list(n = reactive(ret))). I found return(ret) will work, but do not know why it works. However, I need the module to return a list instead of a single value.
There is a trick to pass values from outside to inside shiny module and from inside to outside. It consists in using reactiveValues : you initialise a reactiveValues in your server, you pass it as an argument in you server module, and it is changed inside the module AND outside the module.
You can check this page for more examples.
PS: reactiveValues is a list, so you can pass as much variables as you want inside/ outstide your module(s)
buttonUI <- function(id) {
ns <- NS(id)
tagList(actionButton(ns("btn"), "a button label")
)}
buttonServer <- function(id, parent, rv) { #rv is an argument
moduleServer(id,
## Below is the module function
function(input, output, session) {
ns <- session$ns
ret <- reactiveVal(0)
observeEvent(input$btn,{
rv$btn <- input$btn #increment rv
message("rv_inner", rv$btn)
message("inner", ret())
ret(ret()+1)
})
list(n = reactive(ret)) # no need to return rv
})
}
ui <- fluidPage(
buttonUI("mod")
)
server <- function(input, output, session) {
rv <- reactiveValues(btn = NULL) # initialise reactiveValues
v = buttonServer("mod", rv = rv) # pass reactiveValues as argument
observeEvent(v$n, {
message("outer")
})
observeEvent(rv$btn, { #check rv$btn value
message("rv_outer", rv$btn)
})
}
shinyApp(ui, server)
Here I used a simple trick.
As stated before, you can return a reactive value from a moduleServer and use that value to determine if the button was pressed
In my case, I used an eventReactive() so you can tie a reactive value directly to the actions related to the button
library(shiny)
buttonUI <- function(id) {
ns <- NS(id)
actionButton(ns("btn"), "a button label")
}
buttonServer <- function(id) {
moduleServer(id, function(input, output, session) {
isPressed <- eventReactive(input$btn, {
if(input$btn){
"The button was pressed"
} else {
"The button was NOT pressed"
}
}, ignoreNULL = FALSE)
return(isPressed())
})
}
ui <- fluidPage(
buttonUI("mod"),
textOutput("text")
)
server <- function(input, output, session) {
output$text <- renderText({
buttonServer("mod")
})
}
shinyApp(ui, server)
What I want to achieve is to get access to the reactive value passed to a parent module from a child module. The reproducible example below shows the idea. When i click the button in mod_server_btn then its value should be printed out in the console (from within parent module):
library(shiny)
mod_ui_btn <- function(id, label = "ui1UI") {
ns <- NS(id)
shinyUI(fluidPage(
actionButton(ns("confirm"), "Submit", class='btn-primary')
))
}
mod_server_btn <- function(input, output, session) {
cond <- reactive({ input$confirm})
return(cond)
}
ui =fluidPage(
mod_ui_btn("test"),
uiOutput("example")
)
server=shinyServer(function(input, output, session) {
value <- callModule(mod_server_btn,"test")
print(value)
#print(value$cond) # these 3 don't work either
#print(value()$cond)
#print(value())
})
shinyApp(ui=ui,server=server)
However, it doesn't work. When I click the button then I got a text: reactive({input$confirm}) in the console and it's not what I want, I need to access button value. General question is - is it possible at all to get access to reactive value in a parent module?
EDIT: #rbasa, #YBS thanks for your answers. In fact in my real app I need to return more than one reactive value to parent module. Below is slightly changed code - I added second button in mod_ui_btn - now I need to return values from both buttons to the server module. I made a list of reactives but can't get access to them using observe or output$example <-:
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(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")
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)
I usually use return(list(..some reactive values)) to return more than one ractive value to other module and catch then using their names in parent module. Here it doesn't work even if I use observe. No value is returned.
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)
I try to return some reactive expressions from one module and pass to another module. I know that such a thing is quite easy when passing inputs e.g.:
return(
list(
btn1 = reactive({input$buttonX}),
btn2 = reactive({input$buttonY}))
)
However, I can't return and pass reactive expressions this way, e.g.:
react1 <- reactiveVal()
react2 <- reactiveValues(state = TRUE)
return(
list(
x = react1,
y = react2
)
)
When I return reactives this way then in another module the outcome is just... plain text, in this case it's for example reactiveValues(state = TRUE). It's really strange. This method of returning reactives doesn't work in my case.
Is it possible to return already existing reactives in any sensible way?
EDIT:
I'm adding reproducible example below. In mod_1st_Nested_server I have 3 reactive expr and want to pass one of them to mod_2nd_Nested_server through mod_Parent_server. This is how it works in my real project and need to do it this way but don't know how:
library(shiny)
library(dplyr)
moduleServer <- function(id, module) {
callModule(module, id)
}
# UI 1 #
mod_1st_Nested_UI <- function(id) {
ns <- NS(id)
}
# Server 1 #
mod_1st_Nested_server <- function(id){
moduleServer(id, function(input, output, session) {
# here I have various reactives but want to pass only some of them to parent
btn <- reactive({input$btn})
info <- reactiveValues(logic = TRUE)
other <- reactiveVal()
other("XYZ")
return(list(yyy = info))
})
}
# Parent UI #
mod_Parent_UI <- function(id) {
ns <- NS(id)
tagList(
mod_1st_Nested_UI(ns('first')),
mod_2nd_Nested_UI(ns('second'))
)
}
# Parent Server #
mod_Parent_server <- function(id){
moduleServer(id, function(input, output, session) {
ns <- NS(id)
returnReactive <- mod_1st_Nested_server("first")
mod_2nd_Nested_server('second', returnReactive$yyy) # here I'm passing reactive from module_1st
})
}
# UI 2 #
mod_2nd_Nested_UI <- function(id) {
ns <- NS(id)
tagList(
textOutput(ns("text"))
)
}
# Server 2 #
mod_2nd_Nested_server <- function(id, value){
moduleServer(id, function(input, output, session) {
ns <- NS(id)
output$text <- renderText({ # reactive value from 1st module should be printed here
print(value)
})
})
}
# FINAL App #
ui <- fluidPage(
tagList(
mod_Parent_UI("final")
))
server <- function(input, output, session) {
mod_Parent_server("final")
}
shinyApp(ui = ui, server = server)
How to display a blank UI (alternatively destroy module UI), if the module server-function fails, without moving all the UI-code to the server function?
Simple reproducible example:
library(shiny)
my_module_ui <- function(id) {
ns <- NS(id)
tags$div(
tags$h1("Don't show me if my_module_server fails!"),
plotOutput(ns("my_plot"))
)
}
my_module_server <- function(input, output, session) {
tryCatch({
my_data <- cars * "A" # fail for demo
# my_data <- cars
output$my_plot <- renderPlot({
cars2 <- my_data + rnorm(nrow(my_data))
plot(cars2)
})
}, error=function(cond) {
message("Destroy UI here!")
})
}
ui <- fluidPage(
my_module_ui("my_id")
)
server <- function(input, output, session) {
callModule(my_module_server, "my_id")
}
shinyApp(ui, server)
My current solution is to have nothing but a uiOutput() in my_module_ui and render the entire ui in the server function. I want to prevent this, since large modules get very messy if all UI-components are placed within the module server-function.
In addition I would preferably also like to avoid returning values from callModule() that destroy the UI and do this from within the server-function instead.
Thanks!
How about you assign a value to the session object and evaluate this value before you create the UI (from server side via renderUI().
1) Move rendering of UI to server side
Use renderUI(my_module_ui("my_id")) on server side and uiOutput("module") on ui side.
2) To detect whether your server module was successful assign a value to the session object
my_module_server <- function(input, output, session) {
tryCatch({
...
session$userData$mod_server <- TRUE
}, error = function(cond) {
session$userData$mod_server <- NULL
})
}
3) Use this value to make the call of your module ui conditional
output$module <- renderUI({
callModule(my_module_server, "my_id")
if(!is.null(session$userData$mod_server)) my_module_ui("my_id")
})
Reproducible example:
library(shiny)
my_module_ui <- function(id) {
ns <- NS(id)
tags$div(
tags$h1("Don't show me if my_module_server fails!"),
plotOutput(ns("my_plot"))
)
}
my_module_server <- function(input, output, session) {
tryCatch({
my_data <- cars * "A" # fail for demo
# my_data <- cars
output$my_plot <- renderPlot({
cars2 <- my_data + rnorm(nrow(my_data))
plot(cars2)
})
session$userData$mod_server <- TRUE
}, error = function(cond) {
session$userData$mod_server <- NULL
})
}
ui <- fluidPage(
uiOutput("module")
)
server <- function(input, output, session) {
output$module <- renderUI({
callModule(my_module_server, "my_id")
if(!is.null(session$userData$mod_server)) my_module_ui("my_id")
})
}
shinyApp(ui, server)
With a little code reordering, and the use of the amazing shinyjs package this can be done.
Note that I added an input to simulate errors and not errors, to see how the UI dissapears. Also all is done in the server part of the module. I hope this will help you. The code has inline comments explaining the steps.
library(shiny)
library(shinyjs)
my_module_ui <- function(id) {
ns <- NS(id)
tagList(
# input added to be able to throw errors and see the ui dissapear
selectInput(
ns('trigger'), 'Error trigger',
choices = list('no error' = c(2,1), 'error' = c('A', 'B')),
selected = 2
),
tags$div(
# div with id, to select it with shinyjs and hide it if necessary
id = ns('hideable_div'),
tags$h1("Don't show me if my_module_server fails!"),
plotOutput(ns("my_plot"))
)
)
}
my_module_server <- function(input, output, session) {
# get all the things prone to error in a reactive call, that way you capture the final
# result or a NULL reactive when an error occurs
foo <- reactive({
tryCatch({
if (input$trigger %in% c(2,1)) {
trigger <- as.numeric(input$trigger)
} else {
trigger <- input$trigger
}
cars * trigger
}, error=function(cond) {
message("Destroy UI here!")
})
})
# obseveEvent based on the error reactive, to check if hide or not the UI
observeEvent(foo(), {
# hide checking if foo is null, using shinyjs
if (is.null(foo())) {
shinyjs::hide('hideable_div')
} else {
shinyjs::show('hideable_div')
}
}, ignoreNULL = FALSE, ignoreInit = FALSE)
# outputs, with validation of the error reactive. That way code after validate is not
# executed but the app does not get blocked (gray)
output$my_plot <- renderPlot({
shiny::validate(
shiny::need(foo(), 'no data')
)
cars2 <- foo() + rnorm(nrow(foo()))
plot(cars2)
})
}
ui <- fluidPage(
# really important for shinyjs tu work!!!!!!!
shinyjs::useShinyjs(),
my_module_ui("my_id")
)
server <- function(input, output, session) {
callModule(my_module_server, "my_id")
}
shinyApp(ui, server)