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 pickerInput
s 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)
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 req
uire 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
Extract English Words from a Text in R
Error: Package or Namespace Load Failed for 'Car'
Ggplot Line Plot Different Colors for Sections
Programmatically Create Tab and Plot in Markdown
Subsetting Data Based on Dynamic Column Names
Efficient Way to Fill Time-Series Per Group
Combining Rows Based on a Column
How to Create a Binary Vector with 1 If Elements Are Part of the Same Vector
Is There a Package or Technique Availabe for Calculating Large Factorials in R
Using Italic() with a Variable in Ggplot2 Title Expression
Increase Space Between Legend Keys Without Increasing Legend Keys
Find Closest Points (Lat/Lon) from One Data Set to a Second Data Set
How to Embed Plots into a Tab in Rmarkdown in a Procedural Fashion
How to Use User Input to Obtain a Data.Frame from My Environment in Shiny
Importing Multiple .CSV Files with Variable Column Types into R
How Can One Mix 2 or More Color Palettes to Show a Combined Color Value