R Shiny: Multiple Use in UI of Same Renderui in Server

R shiny: multiple use in ui of same renderUI in server?

You can't (shouldn't) have two elements with the same ID in an HTML document (whether using Shiny or not). Certainly when using Shiny having multiple elements with the same ID will be problematic. I would also subjectively vote that you could substantially improve your code by using meaningful variable names.

It's also not really clear what you want to do with this input. Do you want the input box to be displayed on multiple tabs? Or the value of the textInput to be shown on multiple tabs?

If the former, there's not an obvious way to do that, in my mind, without violating the "multiple elements with the same ID" clause. The latter would be much easier (just use a renderText and send it to a verbatimOutput), but I don't think that's what you're asking.

So what you really want is multiple text inputs (with distinct IDs) that are synchronized. That you can do in separate observers on your server using something like this:

ui <- pageWithSidebar(
headerPanel("Hello !"),
sidebarPanel(
tabsetPanel(
tabPanel("a",
textInput(inputId = "text1", label = "text1", value = "")),
tabPanel("b",
textInput(inputId = "text2", label = "text2", value = ""))
)
),

mainPanel()
)

INITIAL_VAL <- "Initial text"

server <- function(input,output, session){
# Track the current value of the textInputs. Otherwise, we'll pick up that
# the text inputs are initially empty and will start setting the other to be
# empty too, rather than setting the initial value we wanted.
cur_val <- ""

observe({
# This observer depends on text1 and updates text2 with any changes
if (cur_val != input$text1){
# Then we assume text2 hasn't yet been updated
updateTextInput(session, "text2", NULL, input$text1)
cur_val <<- input$text1
}
})

observe({
# This observer depends on text2 and updates text1 with any changes
if (cur_val != input$text2){
# Then we assume text2 hasn't yet been updated
updateTextInput(session, "text1", NULL, input$text2)
cur_val <<- input$text2
}
})

# Define the initial state of the text boxes
updateTextInput(session, "text1", NULL, INITIAL_VAL)
updateTextInput(session, "text2", NULL, INITIAL_VAL)

}

runApp(list(ui=ui,server=server))

There's probably a cleaner way to set the initial state than the cur_val I'm tracking. But I couldn't think of something off the top of my head, so there it is.

Produce two shiny widgets from the same uiOutput() at the same time

Your problem is that if both options are selected in input$DB, then the condition of the first if () statement is TRUE and that is the element of your if-then-else chain that gets executed. So, the first thing to do is to move the "both are selected" element of the chain to the top and adjust your logic accordingly.

Second, to return two (or more) UI elements from the same call to renderUI(), wrap them in a tagList(). Here's a version of your output$fnamesid that works for me:

  output$fnamesid<-renderUI({
if ("Sepal.Length" %in% input$DB & "Sepal.Width" %in% input$DB){
tagList(
pickerInput("sn", "Select sn_ID for x-axis",
choices = unique(iris$Sepal.Length),
multiple = T,options = list(`actions-box` = TRUE),
selected = head(unique(iris$Sepal.Length))),
pickerInput("sn2", "Select sn_ID for x-axis",
choices = unique(iris$Sepal.Width),
multiple = T,options = list(`actions-box` = TRUE),
selected = head(unique(iris$Sepal.Width)))
)
}
else if("Sepal.Length"%in% input$DB){
pickerInput("sn", "Select sn_ID for x-axis",
choices = unique(iris$Sepal.Length),
multiple = T,options = list(`actions-box` = TRUE),
selected = head(unique(iris$Sepal.Length)))
}
else if("Sepal.Width"%in% input$DB){
pickerInput("sn2", "Select sn_ID for x-axis",
choices = unique(iris$Sepal.Width),
multiple = T,options = list(`actions-box` = TRUE),
selected = head(unique(iris$Sepal.Width)))
}

Notice the comma between the two pickerInputs in the tagList. It's important! ;)

Shiny renderUI with multiple inputs

Like I wrote in the first comment, I am unsure about the Make.UI()function. If you really want to keep it as a seperate function you should make it reactive. Or just use it as I did in the code below.
Moreover, in output$dataInfo <- renderPrint({ C is not a reactive() function so you would need to remove brackets there.

library(shiny)
D = matrix(runif(400), nrow = 20)
colnames(D) = labs = sapply(1:20, function(i) {paste0("col",i)})

# Define UI for application that summarises data
ui <- fluidPage(

# Application title
titlePanel("Summaries"),

# Select columns to get fed into summary
tabsetPanel(
tabPanel("Matching Variables Info",
sidebarPanel(

numericInput("NoVars","No. of variables to summarize",
value = 3, min = 2, max = dim(D)[2]),

uiOutput("VarsInput")
),

# Show summaries of columns choosen above
mainPanel(
verbatimTextOutput("dataInfo")
)
)
)
)

# Define the server code
server <- function(input, output){

K <- reactive({
input$NoVars
})

output$VarsInput <- renderUI({
NoV = K()
C = sapply(1:NoV, function(i){paste0("cols",i)})
L = sapply(1:NoV, function(i){paste0("label",i)})

output = tagList()

for(i in seq_along(1:NoV)){
output[[i]] = tagList()
output[[i]][[1]] = selectInput(C[i], "Variable to summarize:", labs)
output[[i]][[2]] = textInput(L[i], label = "Label for variable:",
value = "Label for variable Here")
}

output
})

output$dataInfo <- renderPrint({
C <- sapply(1:K(), function(i) {input[[paste0("cols",i)]]})
## the code in the line above doesn't work

summary(D[, C])
})

}

# Return a Shiny app object
shinyApp(ui = ui, server = server)

Shiny Reactive renderUI and multiple dependent / coupled inputs

Here is a the code in which I have removed the reactive expression from and used a local variable selected_data instead.

  observeEvent(input$submit_request_button, {

# selected_data <- reactive({

# browser()
selected_data <- NULL

if( input$multiple_choice_1_source =="db1"){

selected_data <- mtcars

} else if ( input$multiple_choice_1_source == "db1") {

selected_data <- diamonds

} else if ( input$multiple_choice_1_source == "db3") { selected_data <- NULL

} else if ( input$multiple_choice_1_source == "db4"){selected_data <- NULL
}

# })

user_input_rv$series_picked <- isolate(input$multiple_choice_2_type)

user_input_rv$selected_data <- selected_data

min_cols <- as.integer(1) # default 1
max_cols <- as.integer(length(colnames(selected_data)))
#print(max_cols)

#this renderUI creates the right-hand side column of the app COLUMNS
output$ColnamesInput <- renderUI({

lapply(min_cols:max_cols, function(z) {

column(width = 3,
offset = 0,
selectInput( inputId = paste0("cols","_",z),
label = paste(isolate(input$multiple_choice_2_type),": ",colnames(selected_data)[z]),
choices = unique(selected_data[[z]]),
multiple = TRUE
) #selectizeInput

)

})#lapply inner

}) #renderUI for columns

}) #third observeEvent for data selection and customisation

Now when you change the select input options the ColnamesInput do not get triggered. It gets triggered only after you click the submit button.

[EDIT]:

Might not be the best method, but I think I am able to achieve what you wanted. Also, I have taken the liberty on using the reactiveValue that was already defined in your server. Have a look at the modified server code below:

server <- function(input, output)
{
user_input_rv = reactiveValues(

source_picked = NULL,
last_used_source = NULL,

type_picked = NULL,
series_picked = NULL,
last_used_series = NULL,

selected_data = NULL,
final_selection = NULL
)

observeEvent(input$multiple_choice_1_source, {

user_input_rv$source_picked <- input$multiple_choice_1_source

###Start: To check if the source changed#########
if(!is.null(user_input_rv$last_used_source))
{
if(user_input_rv$last_used_source != user_input_rv$source_picked)
{
shinyjs::hide("ColnamesInput")
user_input_rv$last_used_source = user_input_rv$source_picked
}
}else
{
user_input_rv$last_used_source = user_input_rv$source_picked
}
###End: To check if the source changed#########

#change data loaded under type picked.
user_input_rv$type_picked <-
if ( input$multiple_choice_1_source == "db1"){ paste0(colnames(mtcars))
} else if ( input$multiple_choice_1_source == "db2"){ paste0(colnames(diamonds))
} else if ( input$multiple_choice_1_source == "db3"){ NULL
} else if ( input$multiple_choice_1_source == "db4"){ NULL
}

output$multiple_choice_2_type_ui <- renderUI({

selectizeInput( inputId = 'multiple_choice_2_type',
choices = paste(user_input_rv$type_picked),
label= "2. Select type",
multiple = TRUE,
size = 10,
width = '100%',
options = list( placeholder = 'Type',
maxItems =1
)
)
})

}) #first observeEvent for source type and data load.

observeEvent(input$multiple_choice_2_type,{

###Start: To check if the series changed#########
user_input_rv$series_picked <- input$multiple_choice_2_type

if(!is.null(user_input_rv$last_used_series))
{
if(user_input_rv$last_used_series != user_input_rv$series_picked)
{
shinyjs::hide("ColnamesInput")
user_input_rv$last_used_series = user_input_rv$series_picked
}
}else
{
user_input_rv$last_used_series = user_input_rv$series_picked
}
###End: To check if the series changed#########

output$submit_request_button_ui <- renderUI({

actionButton(
inputId = "submit_request_button",
label = " Get data "
)
})
})#second observeEvent for submit_request_button_ui

observeEvent(input$submit_request_button, {

# selected_data <- reactive({

# browser()
shinyjs::show("ColnamesInput")
selected_data <- NULL

if( input$multiple_choice_1_source =="db1"){

selected_data <- mtcars

} else if ( input$multiple_choice_1_source == "db1") {

selected_data <- diamonds

} else if ( input$multiple_choice_1_source == "db3") { selected_data <- NULL

} else if ( input$multiple_choice_1_source == "db4"){selected_data <- NULL
}

# })

user_input_rv$series_picked <- isolate(input$multiple_choice_2_type)

user_input_rv$selected_data <- selected_data

min_cols <- as.integer(1) # default 1
max_cols <- as.integer(length(colnames(selected_data)))
#print(max_cols)

#this renderUI creates the right-hand side column of the app COLUMNS
output$ColnamesInput <- renderUI({

lapply(min_cols:max_cols, function(z) {

column(width = 3,
offset = 0,
selectInput( inputId = paste0("cols","_",z),
label = paste(isolate(input$multiple_choice_2_type),": ",colnames(selected_data)[z]),
choices = unique(selected_data[[z]]),
multiple = TRUE
) #selectizeInput

)

})#lapply inner

}) #renderUI for columns

}) #third observeEvent for data selection and customisation

}

Hope it helps!

Passing Plots from inside a renderUI in a Shiny Module to main Server

I'm not sure what you mean by "return the plot .... to the app". If all you want to do is display the plot, then this seems to fix the problems in your code:

# Mod1.R File
modUI <- function(id) {

ns <- NS(id)

tagList(
fluidRow(
column(
width = 12,
numericInput(ns("num"), "Choose a number to plot", value = 3),
uiOutput(ns("bins"))
)
)
)
}

modServer <- function(input, output, session) {

ns <- session$ns

output$bins <- renderUI({
tagList(
selectInput(ns("plot_type"), "select plot", c("hist", "plot")),
plotOutput(ns("plott"))
)
})

output$plott <- renderPlot(
if (input$plot_type == "hist"){
hist(input$num)
} else (
plot(input$num)
)
)

}

##############

# App.R File

library(shiny)
library(tidyverse)

# Modules

# Main App ----------------------------------------------------------------

ui <- fluidPage(
modUI("ssss")
) # Fluid Page

server <- function(input, output, session) {
callModule(modServer, "ssss")
}

shinyApp(ui, server)

If you genuinely want to return the plot rather than simply display it, then you'd need to create a reactive containing the plot outside of your output$plott reactive and then return that reactive (not its value) from the module UI. Something like:

modServer <- function(input, output, session) {

ns <- session$ns

output$bins <- renderUI({
tagList(
selectInput(ns("plot_type"), "select plot", c("hist", "plot")),
plotOutput(ns("plott"))
)
})

myPlot <- reactive({
if (input$plot_type == "hist"){
hist(input$num)
} else (
plot(input$num)
)
})

output$plott <- renderPlot({
myPlot()
})

return(myPlot)
}

and

server <- function(input, output, session) {
mainServerPlot <- callModule(modServer, "ssss")
}

You can then reference the plot object returned by the module with mainServerPlot() within the main server.

R/Shiny : RenderUI in a loop to generate multiple objects

Here is an example how to generate boxes dynamically

library(shinydashboard)
library(shiny)

QRSList <- c("Box1","Box2","Box3","Box4","Box5")

ui <- dashboardPage(
dashboardHeader(title = "render Boxes"),
dashboardSidebar(
sidebarMenu(
menuItem("Test", tabName = "Test")
)
),

dashboardBody(
tabItems(
tabItem(tabName = "Test",
fluidRow(
tabPanel("Boxes",uiOutput("myboxes"))
)
)
)
)
)

server <- function(input, output) {

v <- list()
for (i in 1:length(QRSList)){
v[[i]] <- box(width = 3, background = "blue",
title = h3(QRSList[i], style = "display:inline; font-weight:bold"),
selectInput(paste0("slider",i), label = NULL,choices = list("Not good" = "danger", "average" = "warning", "good" = "success"))
)
}
output$myboxes <- renderUI(v)
}

shinyApp(ui = ui, server = server)

Sample Image

In R Shiny, how to control the same object from different conditional panels?

I'm not 100% sure if I got you right but I guess you only need an or in the javascript condition of your conditionalPanel:

condition="input.tabselected==4 || input.tabselected==5"

Please check the following:

library(shiny);library(shinyMatrix);library(shinyjs)

matrix4Default <- matrix(c(0.2), 4, 1,dimnames=list(c("A","B","C","D"),NULL))

matrix4Input <- function(x,matrix4Input){matrixInput(
x, value = matrix4Input, rows = list(extend=FALSE,names=TRUE),
cols = list(extend=FALSE,names=FALSE,editableNames=FALSE),class = "numeric")}

vectorBaseRate <- function(x,y){
a <- rep(y,x)
b <- seq(1:x)
c <- data.frame(x = b, y = a)
return(c)}

vectorBaseRatePlot <- function(w,x,y,z){plot(w[,1],sapply(w[,2],
function(x)gsub("%","",x)),main=x,xlab=y,ylab=z)}

ui <-
pageWithSidebar(headerPanel("Model..."),
sidebarPanel(fluidRow(helpText(h5(strong("Base Input Panel")))), uiOutput("Panels")),
mainPanel(
tabsetPanel(
tabPanel("Liabilities module", value=4,
fluidRow(h5(strong(helpText("Select model output to view:")))),
fluidRow(
actionButton('showRatesValueBtnA','Rates values'),
actionButton('showRatesPlotBtnA','Rates plots')), # close fluid row
uiOutput('showTab4Results')
), # close tab panel
tabPanel("Interest rates", value=5,
fluidRow(h5(strong(helpText("Select model output to view:")))),
fluidRow(
actionButton('showRatesValueBtnB','Rates values'),
actionButton('showRatesPlotBtnB','Rates plots')), # close fluid row
uiOutput('showTab5Results')
), # close tab panel
id = "tabselected"
))) # close tabset panel, main panel, page with sidebar

server <- function(input,output,session)({

showTab4Results <- reactiveValues()
showTab5Results <- reactiveValues()

matrix4 <- reactive(input$matrix4)
baseRate <- function(){vectorBaseRate(60,input$matrix4[1,1])} # Must remain in server section

output$Panels <- renderUI({
conditionalPanel(condition="input.tabselected==4 || input.tabselected==5",actionButton('modRates','Modify Rates'))
}) # close renderUI

vectorRates <- reactive({
if (is.null(input$modRates)){df <- NULL}
else {if(input$modRates < 1){df <- cbind(Period = 1:60,BaseRate = 0.2)}
else {req(input$matrix4)
df <- cbind(Period = 1:60,BaseRate = baseRate()[,2])
} # close 2nd else
} # close 1st else
df
}) # close reactive

output$table5 <- output$table4 <- renderTable({vectorRates()})

observeEvent(input$resetRatesStruct, {updateMatrixInput(session,'matrix4', matrix4Default)})

observeEvent(input$showRatesValueBtnA,
{showTab4Results$showme <- tagList(
fluidRow(h5(strong(helpText("You are viewing Rates values:")))),
tableOutput("table4"))
},ignoreNULL = FALSE)

observeEvent(input$showRatesValueBtnB,
{showTab5Results$showme <- tagList(
fluidRow(h5(strong(helpText("You are viewing Rates values:")))),
tableOutput("table5"))
},ignoreNULL = FALSE)

output$graph5 <- output$graph4 <- renderPlot(vectorBaseRatePlot(vectorRates(),"A Variable","Period","Rate"))

observeEvent(input$showRatesPlotBtnA,{showTab4Results$showme <- tagList(
fluidRow(h5(strong(helpText("You are viewing Rates plots:")))),
plotOutput("graph4"))})

observeEvent(input$showRatesPlotBtnB,{showTab5Results$showme <- tagList(
fluidRow(h5(strong(helpText("You are viewing Rates plots:")))),
plotOutput("graph5"))})

output$showTab4Results <- renderUI({showTab4Results$showme})
output$showTab5Results <- renderUI({showTab5Results$showme})

observeEvent(input$modRates,
{showModal(modalDialog(
matrix4Input("matrix4",if(is.null(input$matrix4)) matrix4Default else input$matrix4),
useShinyjs(),
footer = tagList(
actionButton("resetRatesStruct","Reset"),
modalButton("Close")
)))
showTab4Results$showme <- tagList(tableOutput("table4"))
} # close modalDialog, showModal, and showModal function
) # close observeEvent

}) # close server

shinyApp(ui, server)

Here is a simplified version avoiding the reactiveValues:

library(shiny)
library(shinyMatrix)
library(shinyjs)

matrix4Default <- matrix(c(0.2), 4, 1, dimnames = list(c("A", "B", "C", "D"), NULL))

matrix4Input <- function(x, matrix4Input) {
matrixInput(
x,
value = matrix4Input,
rows = list(extend = FALSE, names = TRUE),
cols = list(
extend = FALSE,
names = FALSE,
editableNames = FALSE
),
class = "numeric"
)
}

vectorBaseRate <- function(x, y) {
a <- rep(y, x)
b <- seq(1:x)
c <- data.frame(x = b, y = a)
return(c)
}

vectorBaseRatePlot <- function(w, x, y, z) {
plot(
w[, 1],
sapply(w[, 2], function(x)
gsub("%", "", x)),
main = x,
xlab = y,
ylab = z
)
}

ui <- pageWithSidebar(
headerPanel("Model..."),
sidebarPanel(fluidRow(helpText(h5(
strong("Base Input Panel")
))), uiOutput("Panels")),
mainPanel(tabsetPanel(
tabPanel(
"Liabilities module",
value = 4,
fluidRow(
radioButtons(
inputId = "showRates4",
label = h5(strong(helpText(
"Select model output to view:"
))),
choices = c('Rates values', 'Rates plots'),
selected = 'Rates values',
inline = TRUE
),
uiOutput('showTab4Results')
)
),
# close tab panel
tabPanel(
"Liabilities module",
value = 5,
fluidRow(
radioButtons(
inputId = "showRates5",
label = h5(strong(helpText(
"Select model output to view:"
))),
choices = c('Rates values', 'Rates plots'),
selected = 'Rates values',
inline = TRUE
),
uiOutput('showTab5Results')
)
),
# close tab panel
id = "tabselected"
))
) # close tabset panel, main panel, page with sidebar

server <- function(input, output, session) {
matrix4 <- reactive(input$matrix4)
baseRate <-
function() {
vectorBaseRate(60, input$matrix4[1, 1])
} # Must remain in server section

output$Panels <- renderUI({
conditionalPanel(condition = "input.tabselected==4 || input.tabselected==5", actionButton('modRates', 'Modify Rates'))
}) # close renderUI

vectorRates <- reactive({
if (is.null(input$modRates)) {
DF <- NULL
}
else {
if (input$modRates < 1) {
DF <- cbind(Period = 1:60, BaseRate = 0.2)
}
else {
req(input$matrix4)
DF <- cbind(Period = 1:60, BaseRate = baseRate()[, 2])
} # close 2nd else
} # close 1st else
DF
}) # close reactive

observeEvent(input$resetRatesStruct, {
updateMatrixInput(session, 'matrix4', matrix4Default)
})

output$table5 <- output$table4 <- renderTable({
vectorRates()
})

output$graph5 <- output$graph4 <- renderPlot({
vectorBaseRatePlot(vectorRates(), "A Variable", "Period", "Rate")
})

output$showTab4Results <- renderUI({
if (input$showRates4 == 'Rates values') {
tagList(fluidRow(h5(strong(
helpText("You are viewing Rates values:")
))),
tableOutput("table4"))
} else {
tagList(fluidRow(h5(strong(
helpText("You are viewing Rates plots:")
))),
plotOutput("graph4"))
}
})

output$showTab5Results <- renderUI({
if (input$showRates5 == 'Rates values') {
tagList(fluidRow(h5(strong(
helpText("You are viewing Rates values:")
))),
tableOutput("table5"))
} else {
tagList(fluidRow(h5(strong(
helpText("You are viewing Rates plots:")
))),
plotOutput("graph5"))
}
})

observeEvent(input$modRates,
{
showModal(modalDialog(
matrix4Input("matrix4", if (is.null(input$matrix4))
matrix4Default
else
input$matrix4),
useShinyjs(),
footer = tagList(
actionButton("resetRatesStruct", "Reset"),
modalButton("Close")
)
))
} # close modalDialog, showModal, and showModal function
) # close observeEvent
} # close server

shinyApp(ui, server)

How to use an input created in renderUI into a reactive function in R Shiny?

You could require that input$server2 is defined and has a valid value before using it further:


d1 <- reactive({
if(input$slider0 == "Yes"){

# Make sure that input$slider2 is ready to be used
req(input$slider2)

# Will be executed as soon as above requirement is fulfilled
d0 %>%
mutate(C3= first_column*input$slider2)

} else {d0 }
})


Related Topics



Leave a reply



Submit