I'm trying to dynamically create some content with a for loop using renderUI and uiOutput but every rendered element only contains the information from the last iteration in the for loop. Example:
require(shiny)
ui <- fluidPage(
uiOutput("out1"),
uiOutput("out2")
)
server <- function(input, output, session) {
count <- 1
for(a in c("hello", "world")){
name <- paste0("out", count)
output[[name]] <- renderUI({
strong(a)
})
count <- count + 1
}
}
shinyApp(ui = ui, server = server)
This outputs world twice instead of hello world
It works when using sapply instead of a for loop:
require(shiny)
ui <- fluidPage(
uiOutput("out1"),
uiOutput("out2")
)
server <- function(input, output, session) {
vec <- c("hello", "world")
sapply(seq_along(vec), function(x) {
name <- paste0("out", x)
output[[name]] <- renderUI({
strong(vec[x])
})
})
}
shinyApp(ui = ui, server = server)
As an alternative to Alexandre's answer I figured out using local({}) also works thanks to Zygmunt Zawadzki's comment:
ui <- fluidPage(
uiOutput("out1"),
uiOutput("out2")
)
server <- function(input, output, session) {
count <- 1
for(a in c("hello", "world")){
local({
b <-a #this has to be added as well
name <- paste0("out", count)
output[[name]] <- renderUI({
strong(b)
})
})
count <- count + 1
}
}
shinyApp(ui = ui, server = server)
Related
I want to do operations on data that has been split into tables. The operations should actually affect all tables eg sum of a column
Here is the code I used to split the data frame.
library(shiny)
ui <- fluidPage(
uiOutput("mytabs")
)
server <- function(input, output) {
df1 <- reactive (split(iris, iris$Species))
output$mytabs <- renderUI({
thetabs <- lapply(paste0('table_', names(df1())),
function(x) {
tabPanel(x,
tableOutput(x))
})
do.call(tabsetPanel, thetabs)
})
observe({
lapply(names(df1()), function(x) {
output[[paste0("table_", x)]] <- renderTable({ df1()[x] })
})
})
}
shinyApp(ui = ui, server = server)
We can add a bslib::value_box in the same tabPanel that the tableOutput goes.
Here's an example, notice the use of map2 instead of lapply, this is to loop through the character with the name of the tables and the tables themselves.
thetabs <- purrr::map2(
paste0("table_", names(df1())),
df1(),
function(x, y) {
tabPanel(
title = x,
value_box(
title = glue::glue("Sum of {x}"),
value = sum(y[['Sepal.Length']]),
showcase = bs_icon("plus")
),
tableOutput(x)
)
}
)
App:
library(shiny)
library(bslib)
library(bsicons)
ui <- fluidPage(
uiOutput("mytabs")
)
server <- function(input, output) {
df1 <- reactive(split(iris, iris$Species))
output$mytabs <- renderUI({
thetabs <- purrr::map2(
paste0("table_", names(df1())),
df1(),
function(x, y) {
tabPanel(
title = x,
value_box(
title = glue::glue("Sum of {x}"),
value = sum(y[['Sepal.Length']]),
showcase = bs_icon("plus")
),
tableOutput(x)
)
}
)
do.call(tabsetPanel, thetabs)
})
observe({
lapply(names(df1()), function(x) {
output[[paste0("table_", x)]] <- renderTable({
df1()[x]
})
})
})
}
shinyApp(ui = ui, server = server)
I’m looking for some help with a simple Shiny app with a modularised design please. I think the problem is a name space issue so the example below is set out as a simplified version of my actual project. My feeling is that I have not set output$uis to the correct name space but I am lost on how to map to it.
The app generates 3 instances of select_formUI and should be namespace related to 3 instances of the server returned values from the callModules of select_form. The values from select_form are passed out in a tibble. The inner module binds all 3 tibbles into one reactive tibble all_gen_forms_rctv.
The process works fine until I uncomment the input_slt_type_db column in pass_back_test, which returns the input$slt_type_db. I’m looking for some help please to include this column in the output and see all_gen_forms_rctv change on user selections via output$outpt_test.
library(shiny)
library(shinyjs)
library(glue)
library(tibble)
select_formUI <- function(id){
ns <- NS(id)
tagList(selectInput(ns('slt_type_db'), 'select letter', choices = letters[1:5]))
}
select_form <- function(input, output, session){
#pass_back_test <- reactive({
tibble(
placehold = "FILL VALUE"
# , input_slt_type_db = input$slt_type_db
)
})
return(list(pass_back_test = reactive({pass_back_test()})))
}
inner_moduleUI <- function(id){
ns <- NS(id)
tagList(uiOutput(ns("outpt_forms_ui")))
}
inner_module <- function(input, output, session){
rctval_ui <- reactiveValues(all_ui=NULL)
gen_forms <- reactiveValues()
all_gen_forms_rctv <- reactive({
dplyr::bind_rows(lapply(reactiveValuesToList(gen_forms), function(current_module_output) {
current_module_output$pass_back_test()
}))
})
observeEvent(input$btn_start ,{
for(i in 1:3){
x_id = glue("mod_{i}")
rctval_ui$all_ui[[x_id]] <- select_formUI(x_id)
gen_forms[[x_id]] <- callModule(select_form, x_id)
}
})
output$outpt_forms_ui <- renderUI({
ns <- session$ns
tagList(
actionButton(ns('btn_start'), label = 'start'),
verbatimTextOutput(ns('outpt_test')),
hr(),
uiOutput(ns('uis'))
)
})
output$uis <- renderUI({
ns <- session$ns
tags$div(id = environment(ns)[['namespace']],
tagList(rctval_ui$all_ui))
})
output$outpt_test <- renderPrint({all_gen_forms_rctv()})
}
ui <- fluidPage(
useShinyjs(),
uiOutput('main_ui')
)
server <- function(input, output, session) {
output$main_ui <- renderUI({inner_moduleUI('inner_ns')})
callModule(inner_module, 'inner_ns')
}
shinyApp(ui = ui, server = server)
the problem is that the UI function of the select_form modul doesn't know that it is being called within another module. So you need to tell it by wrapping the the id in session$ns. The callModule function can handle this by itself so here there is no need to change anything. The inner_module function would the look like this
inner_module <- function(input, output, session) {
rctval_ui <- reactiveValues(all_ui=NULL)
gen_forms <- reactiveValues()
all_gen_forms_rctv <- reactive({
browser()
dplyr::bind_rows(lapply(reactiveValuesToList(gen_forms), function(current_module_output) {
current_module_output$pass_back_test()
}))
})
observeEvent(input$btn_start ,{
for(i in 1:3){
x_id = glue("mod_{i}")
rctval_ui$all_ui[[x_id]] <- select_formUI(session$ns(x_id))
gen_forms[[x_id]] <- callModule(select_form, x_id)
}
})
output$outpt_forms_ui <- renderUI({
ns <- session$ns
tagList(
actionButton(ns('btn_start'), label = 'start'),
verbatimTextOutput(ns('outpt_test')),
hr(),
uiOutput(ns('uis'))
)
})
output$uis <- renderUI({
ns <- session$ns
tags$div(id = environment(ns)[['namespace']],
tagList(rctval_ui$all_ui))
})
output$outpt_test <- renderPrint({all_gen_forms_rctv()})
}
Suppose I have the following shiny app that renders a data table from the package DT:
library(shiny)
ui <- fluidPage(uiOutput("abc"))
server <- function(input, output, session) {
output$abc <- renderUI({DT::dataTableOutput("dt_output")}) # line 4
output$dt_output <- DT::renderDataTable({data.table(a = 1:3, b = 4:6)}) # line 5
}
runApp(list(ui = ui, server = server))
How would you combine lines 4 and 5, with the constraint that output$abc must remain a uiOutput?
My attempt at combining (the code below) led to an error, "cannot coerce type closure":
output$abc <- renderUI({DT::dataTableOutput(
DT::renderDataTable({data.table(a = 1:3, b = 4:6)}))})
This should work:
library(shiny)
ui <- fluidPage(
uiOutput("abc")
)
server <- function(input, output, session) {
output$abc <- renderUI({
output$aa <- DT::renderDataTable(head(mtcars))
DT::dataTableOutput("aa")
})
}
runApp(list(ui = ui, server = server))
I'm making an app in which the user can create as many tables as he/she wants and display the code necessary to remake each individual table using shinymeta. I can generate the code for each of these tables but I have a problem when I want to create a complete modal that shows every code for each table.
To be clearer, here's a reproducible example:
library(shiny)
library(dplyr)
library(shinymeta)
module_ui <- function(id){
ns <- NS(id)
tagList(
fluidRow(
actionButton(ns("show_table"), "Show table"),
actionButton(ns("show_code"), "Show code"),
tableOutput(ns("table"))
)
)
}
module_server <- function(input, output, session){
data <- metaReactive2({
req(input$show_table)
isolate(metaExpr({
mtcars
}))
})
data2 <- metaReactive({
..(data()) %>%
select(mpg)
})
output$table <- renderTable({
data2()
})
observeEvent(input$show_code, {
showModal(modalDialog(
renderPrint({
expandChain(data(), data2())
})
))
})
return(data())
}
ui <- fluidPage(
actionButton("launch", "Launch"),
actionButton("show_full_code", "Show the full code (at least 2 'launch' before)")
)
server <- function(input, output, session) {
count <- reactiveValues(value = 0)
observeEvent(input$launch, {
count$value <- count$value + 1
insertUI(selector = "#show_full_code",
where = "afterEnd",
ui = module_ui(paste0("x", count$value)))
callModule(module_server, paste0("x", count$value))
})
#### "Merge" the single code modals in one big
observeEvent(input$show_full_code, {
showModal(modalDialog(
renderPrint({
expandChain(x1_data)
})
))
})
}
shinyApp(ui, server)
When you click on "Launch", two buttons are generated and you can display a table ("Show table") and the code to remake this table ("Show code"). You can click on "Launch" indefinitely and the table will be named x1_data, x2_data, etc.
However, when I try to generate the code that unites every individual code (by clicking on "Show the full code"), x1_data is not found. Using x1_data() does not work either. I'm not a fan of asking two questions in one post but I will do this now:
How can I access the reactive elements created inside modules?
How can I "merge" every individual code in a big one?
Also asked on RStudio Community
Edit: following a comment, I add a second reactive expression in my example, so that I can't use return on both of them.
Ok, I came up with an answer that has the module return the expandChain() results rather than trying to render them again in the server:
library(shiny)
library(dplyr)
library(shinymeta)
module_ui <- function(id){
ns <- NS(id)
tagList(
fluidRow(
actionButton(ns("show_table"), "Show table"),
actionButton(ns("show_code"), "Show code"),
tableOutput(ns("table"))
)
)
}
module_server <- function(input, output, session){
data <- metaReactive2({
req(input$show_table)
isolate(metaExpr({
mtcars
}))
})
data2 <- metaReactive({
..(data()) %>%
select(mpg)
})
output$table <- renderTable({
data2()
})
observeEvent(input$show_code, {
showModal(modalDialog(
renderPrint({
expandChain(data(), data2())
})
))
})
########################################
### create list of reactive objects ####
########################################
return(list(
expandChain(data(), data2())
)
)
}
ui <- fluidPage(
actionButton("launch", "Launch"),
actionButton("show_full_code", "Show the full code (at least 2 'launch' before)")
)
server <- function(input, output, session) {
count <- reactiveValues(value = 0)
observeEvent(input$launch, {
count$value <- count$value + 1
insertUI(selector = "#show_full_code",
where = "afterEnd",
ui = module_ui(paste0("x", count$value)))
callModule(module_server, paste0("x", count$value))
})
#### "Merge" the single code modals in one big list object
my_data <- reactive({
req(count$value)
my_set <- 1:count$value
### lapply through the different name spaces so all are captured ###
final <- lapply(my_set, function(x){
temp <- callModule(module_server, paste0("x", x))
return(temp)
})
return(final)
})
#### "Merge" the single code modals in one big
observeEvent(input$show_full_code, {
showModal(modalDialog(
renderPrint({
temp <- sapply(unlist(my_data()), function(x){
print(x)
})
})
))
})
}
shinyApp(ui, server)
Beginner to R and shiny here!
Tried to make a minimal working example... I want to check a condition on a reactive input value. What am I doing wrong?
library(shiny)
ui<-fluidPage(
numericInput(inputId="a", label=NULL, value=0),
textOutput(outputId="out")
)
server <- function(input, output) {
x <- reactive(input$a)
if (x() < 4)
{y<-1}
else
{y<-0}
output$out <- renderText({y})
}
shinyApp(ui = ui, server = server)
The error message:
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.)
You just need to use reactive with your if so that shiny knows that y changes when x does.
library(shiny)
ui<-fluidPage(
numericInput(inputId="a", label=NULL, value=0),
textOutput(outputId="out")
)
server <- function(input, output) {
x <- reactive(input$a)
y <- reactive( if (x()<4) 1 else 0 )
output$out <- renderText({ y() })
}
shinyApp(ui = ui, server = server)
The answer above from John Paul is certainly acceptable, but I thought you might like to see another way as a part of your learning process. I will let StackOverflow sort out which is more advisable.
library(shiny)
ui<-fluidPage(
numericInput(inputId="a", label=NULL, value=0),
textOutput(outputId="out")
)
server <- function(input, output) {
state <- reactiveValues()
observe({
state$x <- input$a
state$y <- ifelse(state$x < 4, 1, 0)
})
output$out <- renderText({ state$y })
}
shinyApp(ui = ui, server = server)
here's my attempt.
1) as stated, you don't need to wrap input$a in reactive context and save as x. just use input$a
2) you don't need reactiveValues in this simple example. just save y as a reactive variable. then, in the renderText, access by calling the function ("y()")
library(shiny)
ui<-fluidPage(
numericInput(inputId="a", label=NULL, value=0),
textOutput(outputId="out")
)
server <- function(input, output) {
y <- reactive({
if (input$a < 4) {
return(1)
} else {
return(0)
}
}
)
output$out <- renderText({y()})
}
shinyApp(ui = ui, server = server)