I am experimenting with Shiny and async programming in the hopes of using it in a larger, more complex, public application.
In this example, I thought that unlist() would wait until the value of v1 is returned because of the use of future_promise and the promise pipe, %...>%.
However, I get the error:
Error in unlist: object 'v1' not found
How can I get this demo code to work?
app.R
library("zeallot")
library("shiny")
library("primes")
library("future")
library("promises")
library("tidyverse")
plan(multisession)
source("/home/law/whatbank_multicore_test/src/expensive_calc.R")
ui <- fluidPage(
actionButton("do", "Do Expensive Calc"),
textOutput("text")
)
server <- function(input, output, session) {
observeEvent(input$do, {
output$text <- renderText({
future_promise(zeallot::`%<-%`(c(v1, v2), expensive_calc()), seed = TRUE) %...>%
{
tmp <- unlist(v1)
}
})
})
}
shinyApp(ui, server)
expensive_calc.R
expensive_calc <- function(){
min <- 10000
max_num <- sample(80000:210000, 1)
rap <- ruth_aaron_pairs(min, max_num, distinct = FALSE)
list(rap, 11)
}
As pointed out to me in the RStudio Community the zeallot call needs to be within the future_promise braces. Here is the solution:
server <- function(input, output, session) {
observeEvent(input$do, {
output$text <- renderText({
future_promise(seed = TRUE) %...>%
{
zeallot::`%<-%`(c(v1, v2), expensive_calc())
tmp <- unlist(v1)
}
})
})
}
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 try to use reactive expression inside function I wrote. What I need to do is to pass some data to function (as parameter) and then return value from reactive expression. Unfortunately when I run this code then I got an error: 'data' must be a data frame or matrix. Btw 'data' I'm passing to function is already a data frame. Is it something wrong with my code? I mean using reactive in function?
library(shiny)
library(dplyr)
moduleServer <- function(id, module) {
callModule(module, id)
}
mod_btn_ui <- function(id) {
ns <- NS(id)
tagList(
verbatimTextOutput(ns("x"))
)
}
mod_btn_server <- function(id){
moduleServer(id, function(input, output, session) {
ns <- NS(id)
output$x <- renderPrint({
print(reactiveDf2(quakes))
})
reactiveDf2 <- function(data){
x <- 1
r <- reactive({
if (x == 2) {
newDf <- data
} else {
newDf <- data[1:10,]
}
})
return(r)
}
})
}
# Final app #
ui <- fluidPage(
tagList(
mod_btn_ui("test"))
)
server <- function(input, output, session) {
mod_btn_server("test")
}
shinyApp(ui = ui, server = server)
When I run the code there is no data in text area displayed.
I have a function which I'd like to handle multiple outputs but base it off of the input to the function. For example, in the following code side could refer to any number of maps on the page, e.g. 10:
library(shiny)
ui <- fluidPage(
textOutput("m1"),
textOutput("m2")
)
f <- function(output, side) {
m = output[[paste0('m', side)]]
print(m)
}
server <- function(input, output, session) {
f(output, 1)
f(output, 2)
}
shinyApp(ui, server)
However, running this code results in the following error:
Warning: Error in [[.shinyoutput: Reading from shinyoutput object is not allowed.
You have to create a reactive context for each output. This would be the first solution of doing it. This way you write a function that creates a renderText output in each call.
library(shiny)
ui <- fluidPage(
textInput("in1", "Value"),
textOutput("m1"),
textOutput("m2")
)
server <- function(input, output, session) {
f <- function(outputId, side) {
output[[outputId]] <<- renderText({
paste0('m', side, " - ", input$in1)
})
}
f("m1", 1)
f("m2", 2)
}
shinyApp(ui, server)
The solution above duplicates code. For most apps that shouldn't be a problem. But if you need to avoid that:
library(shiny)
ui <- fluidPage(
textInput("in1", "Value"),
textOutput("m1"),
textOutput("m2")
)
server <- function(input, output, session) {
f <- function(outputId, side) {
paste0('m', side, " - ", input$in1)
}
output$m1 <- renderText({
f("m1", 1)
})
output$m2 <- renderText({
f("m2", 2)
})
}
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)
I'd like to output several tables as a one uiOutput. If I put them together in a list using a loop then all outputs are equal to the last one.
Example:
library(shiny)
ui <- fluidPage(
mainPanel(
uiOutput("tables")
)
)
server <- function(input, output) {
output$tables <- renderUI({
data=array(rnorm(150),c(10,5,3))
tfc = function(m){
# x = m[1,1]
renderTable({m})
}
result=list()
for(i in 1:3)
result[[i]] = tfc(data[,,i])
return(result)
})
}
shinyApp(ui = ui, server = server)
If I remove the commented line (x = m[1,1]) I get the desired result.
I can live with this workaround but is there a reason why shiny behaves like that or is there a different way to do it?
I usually use lapply for such usecases. This way, you don't run into issues with lazy evaluation.
library(shiny)
ui <- fluidPage(
mainPanel(
uiOutput("tables")
)
)
server <- function(input, output) {
output$tables <- renderUI({
data=array(rnorm(150),c(10,5,3))
tfc = function(m){renderTable({m})}
lapply(1:3, function(i){tfc(data[,,i])})
})
}
shinyApp(ui = ui, server = server)
If you want to use a reacive table, you can use something like
tfc = function(m, output, id){
output[[id]] <- renderTable({m()})
tableOutput(id)
}
instead.
To get around this, you can force evaluation of function arguments:
tfc = function(m) {
force(m)
renderTable(m)
}
or
create a local scope for each loop iteration:
for (i in 1:3) {
local({
i <- i
result[[i]] <<- tfc(data[,,i])
})
}
lapply works as well, but only for R versions 3.2 and above: https://cran.r-project.org/bin/windows/base/old/3.2.0/NEWS.R-3.2.0.html