I a newbie in shiny and I want to add input$n widgets to my webpage, where input$n is a numeric given by another widget in my page?
Is it possible? And how?
Thank you very much for your help!
You can achieve this by using Shiny Modules. In the following example, the application dynamically creates N textInput from a numericInput.
library(shiny)
# Module UI containing a widget
widgetUI <- function(id, i) {
ns <- NS(id)
tagList(
textInput(inputId = ns("text"), label = paste("widget", i))
)
}
# Module server, unused here, just prints the widgets value in console
widgetServer <- function(input, output, session) {
observeEvent(input$text,{
print(input$text)
})
}
# Main UI page
ui <- fluidPage(
numericInput(inputId = "n", label = "Number of widgets", value = 2),
uiOutput("widgets")
)
# Main server
server <- function(input, output, session) {
output$widgets <- renderUI({
req(input$n)
# call the module UI n times
tagList(
lapply(1:input$n, function(i) {
widgetUI(id = paste0("widget", i), i)
})
)
})
observe({
# call the module server n times
lapply(1:input$n, function(i) {
callModule(widgetServer, id = paste0("widget", i))
})
})
}
shinyApp(ui, server)
Related
Let's say I have 4 sets of UI/Server modules in 4 different directories ("./X1/Y1/", "./X1/Y2/", "./X2/Y1/", "./X2/Y2/"). I want to load the selected set based on the input in the sidebar.
I tried using source() within dashboardBody(), but I was not successful.
library(shiny)
library(shinydashboard)
# path to modules
in_path <- "C:/a/b/c/"
# ui
ui <- dashboardPage(
dashboardHeader(title = "test"),
dashboardSidebar(
br(),
selectInput('f1', 'Folder 1', choices = c("X1", "X2")),
helpText(""),
selectInput('f2', 'Folder 2', choices = c("Y1", "Y2")),
br(),
actionButton("load", "Load", icon("thumbs-up"), width = "85%")
),
dashboardBody(
# UI module here from, e.g., "C:/a/b/c/X1/Y2/my_UI.R"
)
)
# server
server <- function(input, output, session) {
# server module here from, e.g., "C:/a/b/c/X1/Y2/my_Server.R"
}
shinyApp(ui, server)
As shiny modules are simply functions, I'd source them in the beginning, and use uiOutput to display the differnt modules.
Here's a working example of the general idea (sample module code proudly stolen from the official Shiny documentation):
<mod1.R>
counterButton <- function(id, label = "Counter") {
ns <- NS(id)
tagList(
actionButton(ns("button"), label = label),
verbatimTextOutput(ns("out"))
)
}
counterServer <- function(id) {
moduleServer(
id,
function(input, output, session) {
count <- reactiveVal(0)
observeEvent(input$button, {
count(count() + 1)
})
output$out <- renderText({
count()
})
count
}
)
}
<mod2.R>
csvFileUI <- function(id, label = "CSV file") {
ns <- NS(id)
tagList(
fileInput(ns("file"), label),
checkboxInput(ns("heading"), "Has heading"),
selectInput(ns("quote"), "Quote", c(
"None" = "",
"Double quote" = "\"",
"Single quote" = "'"
))
)
}
csvFileServer <- function(id, stringsAsFactors = TRUE) {
moduleServer(
id,
## Below is the module function
function(input, output, session) {
# The selected file, if any
userFile <- reactive({
# If no file is selected, don't do anything
validate(need(input$file, message = FALSE))
input$file
})
# The user's data, parsed into a data frame
dataframe <- reactive({
read.csv(userFile()$datapath,
header = input$heading,
quote = input$quote,
stringsAsFactors = stringsAsFactors)
})
# We can run observers in here if we want to
observe({
msg <- sprintf("File %s was uploaded", userFile()$name)
cat(msg, "\n")
})
# Return the reactive that yields the data frame
return(dataframe)
}
)
}
<app.R>
library(shiny)
source("mod1.R")
source("mod2.R")
my_mods <- list("Counter Button" = list(ui = counterButton,
server = counterServer),
"CSV Uploader" = list(ui = csvFileUI ,
server = csvFileServer))
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("mod_sel",
"Which Module should be loaded?",
names(my_mods))
),
mainPanel(
uiOutput("content"),
verbatimTextOutput("out")
)
)
)
server <- function(input, output) {
uuid <- 1
handler <- reactiveVal()
output$content <- renderUI({
my_mods[[req(input$mod_sel)]]$ui(paste0("mod", uuid))
})
observeEvent(input$mod_sel, {
handler(my_mods[[req(input$mod_sel)]]$server(paste0("mod", uuid)))
uuid <<- uuid + 1
})
output$out <- renderPrint(req(handler())())
}
shinyApp(ui, server)
Some Explanation
You put the module code in mod[12].R and it is rather straight forward.
In your main app, you load both(!) source files and for housekeeping reasons, I put both modules functions (ui and server) in a list, but this is not strictly necessary, but facilitates future extension.
In your UI you have an uiOutput which renders dynamically according to the selected module.
In your server you put the code to dynamically render the UI and call the respective server function.
The uid construct is basically there to force a fresh render, whenever you change the selection. Otherwise, you may see still some old values whenever you come back to a module which you have rendered already.
My shinyapp is build using modules, the radioBox component inputId = modelling_type is created in the server, using a renderUI function and stored under outputId = modelling_type_ui
As I'm using modules, I have name spaced my IDs in the mod_ui, and then in order to (attempt!) to use the same name space function in the mod_server I have called it via ns <- parentsession$ns. This doesn't throw an error. But I would now expect to access the value of the RadioBox via input$modelling_type
This isn't working! So I must be calling the value incorrectly.
Here is the code:
library(shiny)
library(shinyalert)
library(shinydashboard)
library(shinyjs)
library(tidyverse)
# modules ------------------------------------------
mod_ui <- function(id){
ns <- NS(id)
fluidPage(
uiOutput(outputId = ns("modelling_type_ui")),
textOutput(outputId = ns("capture"))
)
}
mod_server <- function(id, parentsession){
moduleServer(id,
function(input, output, server){
ns <- parentsession$ns
output$modelling_type_ui = renderUI({
print(input$modelling_type) # this should not be null
radioButtons(
inputId = ns("modelling_type"),
label = "Choose a modelling technique",
choices = c("OLS",
"Bayesian"),
selected = "OLS")
})
output$capture = renderText({ paste0("modelling type selected:", input$modelling_type) })
})
}
# call app ---------------------------------------
# run app
ui <- function(){ mod_ui("mt") }
server <- function(input, output, session){ mod_server("mt", session) }
shinyApp(ui = ui, server = server)
Any help appreciated. Usually I would just call radioButtons in the UI, and use updateradioButtons function in the server, but I'm dealing with a legacy app which uses the below method repeatedly.
To expand on my comment above, here is a MWE that I believe does what you want.
I'm not sure why you're using uiOutput and renderUI. I assume it's needed in your actual use case, but it's not needed here. Also, there's no need to muck about with parentsession and the like.
One reason why your debug print prints NULL is that you haven't defined the radio group at the time you try to print its value.
library(shiny)
library(tidyverse)
mod_ui <- function(id){
ns <- NS(id)
fluidPage(
uiOutput(outputId = ns("modelling_type_ui")),
textOutput(outputId = ns("capture"))
)
}
mod_server <- function(id) {
moduleServer(
id,
function(input, output, session){
ns <- session$ns
output$modelling_type_ui = renderUI({
radioButtons(
inputId = ns("modelling_type"),
label = "Choose a modelling technique",
choices = c("OLS","Bayesian"),
selected = "OLS"
)
})
output$capture <- renderText({
paste0("modelling type selected: ", input$modelling_type)
})
rv <- reactive({
input$modelling_type
})
return(rv)
}
)
}
ui <- function() {
fluidPage(
mod_ui("mt"),
textOutput("returnValue")
)
}
server <- function(input, output, session) {
modValue <- mod_server("mt")
output$returnValue <- renderText({
paste0("The value returned by the module is ", modValue())
})
}
shinyApp(ui = ui, server = server)
My application generates both automatic Ui and can also add ui manually. I have used both renderUI and InsertUI in the main application to call shiny modules.
The normal use case of shiny module even with renderUI function in module server updates my values nicely. But when I am generating shiny modules by invoking insertUI and renderUI function, the input values(selectInput, numericInput) are not updating. I am not understanding the reason for this, can anyone answer my problem.
Here is my workable code
Problem observing Shiny Module update inputs
# Module UI
ui_module <- function(id){
ns <- NS(id)
fluidRow(
uiOutput(ns("Input_ui"))
)
}
# Server UI
server_module <- function(input,output,session){
ns <- session$ns
output$Input_ui <- renderUI({
list(
tags$div(id = ns("input_div"),numericInput(ns("Input"),"Number",NA,value = 537153, step = 1)),
tags$div(id = ns("input2_div"),numericInput(ns("Input2"),"Number2",NA,value=686575,step = 1))
)
})
## INPUTS are not updating ##
observe({
updateNumericInput(session,
"Input", "Number",value = 4, step = 1)
updateNumericInput(session,
"Input2", "Number2",value = 8.9, step = 1)
})
}
# App UI
ui <- fluidPage(
fluidRow(id = "Row",
uiOutput("ui"),
actionButton("add","ADD")
)
)
# Server UI
server <- function(input,output,session){
# Initiating counter
n <- 0
# One by one adding the modules
observeEvent(input$add,{
n <<- n + 1
panels <- paste0("panels_new",n)
insertUI("#Row",
"beforeEnd",
ui_module(panels))
callModule(server_module,panels)
})
# Generating a no of shiny modules based on the some table rows
output$ui <- renderUI({
n <- 2 # n will be nrow in my main app.
list <- as.list(1:n)
lapply(list, function(i){
panels <- paste0("panels",i)
fluidRow(
ui_module(panels)
)
})
})
observe({
n <- 2 # n will be nrow in my main app.
list <- as.list(1:n)
lapply(list, function(i){
panels <- paste0("panels",i)
callModule(server_module,panels)
})
})
}
shinyApp(ui,server)
Normal Use case of Shiny Module (updation works)
#Module UI
ui_module <- function(id){
ns <- NS(id)
fluidRow(
uiOutput(ns("Input_ui"))
)
}
#Module Server
server_module <- function(input,output,session){
ns <- session$ns
output$Input_ui <- renderUI({
list(
tags$div(id = ns("input_div"),numericInput(ns("Input"), "Number",NA,value = 537153, step = 1)),
tags$div(id = ns("input2_div"),numericInput(ns("Input2"),"Number2",NA,value = 686575, step =1))
)
})
observe({
updateNumericInput(session,
"Input", "Number",value = 4, step = 1)
updateNumericInput(session,
"Input2", "Number2",value = 8.9, step = 1)
})
}
#APP UI
ui <- fluidPage(
fluidRow(id = "Row",
ui_module("panels")
)
)
#APP Server
server <- function(input,output,session){
callModule(server_module,"panels")
}
shinyApp(ui,server)
Your module server function isn't returning anything, so the main
server module doesn't know that anything has changed.
You don't need to namespace the inputs in the module server function. They're
already namespaced
What do you want to update and when? it's not at all clear...
I want to create a UI module, insert it, and obtain an input object from the server module. I then want to observe events on this input object.
Currently, I return an input object as a reactive value from callModule. However, the observer I create only fires once (on initialisation).
Can anyone tell me if what I am trying to do is possible, and where I'm going wrong? Code attached. Thanks in advance.
John
app.R
library(shiny)
source("added.R")
source("addedUI.R")
# Define UI for application that draws a histogram
ui <- fluidPage(
actionButton("add_id", "Add"),
actionButton("print_id", "Print list"),
tags$hr(),
tags$div(id = "div"),
tags$hr()
)
# Define server logic required to draw a histogram
server <- function(input, output) {
id <- 0
rv <- list()
next_id <- function()
{
id <<- id + 1
return (as.character(id))
}
observeEvent(input$print_id,
{
print(rv)
})
observeEvent(input$add_id,
{
x <- next_id()
ui <- addedUI(x)
insertUI(selector = sprintf("#%s", "div"), where = "beforeEnd", ui = ui)
rv[[x]] <<- callModule(added, x)
observeEvent(rv[[x]],
{
print(sprintf("Observed %s: ", x))
})
print(rv)
})
}
# Run the application
shinyApp(ui = ui, server = server)
added.R
added <- function(input, output, session)
{
return (reactive(input$text_id))
}
addedUI.R
addedUI <- function(id)
{
ns <- NS(id)
tags$div(textInput(ns("text_id"), "Text", value = "Abc"))
}
You need to use observeEvent(rv[[x]](), ...) to read the current value from the reactive. Otherwise you recieve the reference to the reactive object, which is not observable. Same for the print_id observer.
library(shiny)
added <- function(input, output, session)
{
return (reactive(input$text_id))
}
addedUI.R
addedUI <- function(id)
{
ns <- NS(id)
tags$div(textInput(ns("text_id"), "Text", value = "Abc"))
}
# Define UI for application that draws a histogram
ui <- fluidPage(
actionButton("add_id", "Add"),
actionButton("print_id", "Print list"),
tags$hr(),
tags$div(id = "div"),
tags$hr()
)
# Define server logic required to draw a histogram
server <- function(input, output) {
id <- 0
rv <- list()
next_id <- function()
{
id <<- id + 1
return (as.character(id))
}
observeEvent(input$print_id,
{
print(lapply(rv, function(x){x()}))
})
observeEvent(input$add_id,
{
x <- next_id()
ui <- addedUI(x)
insertUI(selector = sprintf("#%s", "div"), where = "beforeEnd", ui = ui)
rv[[x]] <<- callModule(added, x)
observeEvent(rv[[x]](),
{
print(sprintf("Observed %s: ", x))
})
print(rv)
})
}
# Run the application
shinyApp(ui = ui, server = server)
I have created a sample app below to illustrate the issue I am having. I have an application in Shiny that is using many layers of modules. I am very familiar with using modules and returning reactive values from the modules themselves. However when I need to use lapply to create multiple calls of modules (in this case slider_menu_item_shiny function to create multiple sliders), each which return the reactive value that is set by the user in sliders, I am not sure how to dynamically capture all of the output reactive variables into one reactive vector.
Right now I have 2 sliders hard coded in and this simple app works. However I want to be able to type in an arbitrary value in the first input, have the app create that amount of slider modules using the lapply statement (for the callModule(slider_menu_item_shiny) call too) and then have slider_value_vector contain a vector of that length with all of the slider values.
I feel like I am missing a fundamental trick to making this work. I would really appreciate the learning experience and all of the help.
ui.R code
library(shiny)
library(shinydashboard)
library(DT)
#### MODULE CODE ####
source("modules.R")
# define header
header <- dashboardHeader(
title = "Test"
)
# define body
body <- dashboardBody(
tabItems(
body_set_shinyUI(id = "body_test_mod", tab_name = "body_test_mod")
)
)
# define sidebar
sidebar <- dashboardSidebar(
sidebarMenu(id = "dashboard_menu",
menuItem("Test Body", tabName = "body_test_mod")
)
)
dashboardPage(skin = "blue",
header,
sidebar,
body
)
server.R code
library(shiny)
library(shinydashboard)
library(DT)
#### MODULE CODE ####
source("modules.R")
#### SERVER CODE ####
function(input, output, session) {
callModule(body_set_shiny, id = "body_test_mod")
}
modules.R code
### body_set_shiny
body_set_shinyUI <- function(id, tab_name) {
ns <- NS(id)
tabItem(tabName = tab_name,
fluidRow(
column(12,
inner_body_test_menu_shinyUI(ns("inner_body_test_mod"))
)
)
)
}
body_set_shiny <- function(input, output, session) {
callModule(inner_body_test_menu_shiny, id = "inner_body_test_mod")
}
### inner_body_test_menu_shiny
inner_body_test_menu_shinyUI <- function(id) {
ns <- NS(id)
fluidRow(
column(12,
box(title = "Test Inner Menu",
width = 12,
fluidRow(
column(12,
wellPanel(
uiOutput(ns("inner_number_menu")),
uiOutput(ns("inner_sliders_menu")),
uiOutput(ns("inner_text_output"))
)
)
)
)
)
)
}
inner_body_test_menu_shiny <- function(input, output, session) {
output$inner_number_menu <- renderUI({
ns <- session$ns
textInput(ns("inner_number_value"), label = "Enter Number of Sliders", value = "2")
})
slider_length <- reactive({
if (is.null(input$inner_number_value))
return()
as.numeric(input$inner_number_value)
})
output$inner_sliders_menu <- renderUI({
if (is.null(slider_length()))
return()
ns <- session$ns
lapply((1:slider_length()), function(m) {
slider_menu_item_shinyUI(ns(paste("slider_menu_item_", m, sep = "")))
})
})
output$inner_text_output <- renderText({
if (is.null(slider_value_vector()))
return()
paste("You have entered", slider_value_vector())
})
slider_value_vector <- reactive({
if (is.null(slider_length()))
return()
c(as.numeric(slider_v1()[[1]]),as.numeric(slider_v2()[[1]]))
})
slider_v1 <- callModule(slider_menu_item_shiny, paste("slider_menu_item_", 1, sep = ""))
slider_v2 <- callModule(slider_menu_item_shiny, paste("slider_menu_item_", 2, sep = ""))
}
slider_menu_item_shinyUI <- function(id) {
ns <- NS(id)
uiOutput(ns('sider_output_menu'))
}
slider_menu_item_shiny <- function(input, output, session, slider_value = 0, slider_name = "No Name Found") {
output$sider_output_menu <- renderUI({
ns <- session$ns
uiOutput(ns("slider_item_menu"))
})
output$slider_item_menu <- renderUI({
ns <- session$ns
sliderInput(ns("slider_item"), label = "Slider Example", min = -1, max = 1, value = 0.5, step = 0.01)
})
return(reactive(list(input$slider_item)))
}