I have a weird issue with conditionalPanel in shiny dashboard.
I modularized my chart UI components as I need to call it multiple times.
The conditional Panel seems to work fine if I call it only once. However, if I attempted to call more than once, it stopped working.
Below is the reproducible code:
library(shiny)
library(shinyWidgets)
library(shinydashboard)
library(shinydashboardPlus)
library(highcharter)
library(lubridate)
chartUI <- function(id) {
ns <- NS(id)
tagList(
verbatimTextOutput(ns("group")),
selectInput(ns("freq"),"Select frequency:",
choices = list("Yearly" = "Y","Half yearly" = "H","Quarterly" = "Q",
"Monthly"="M"), selected = "Yearly", multiple = FALSE),
dateInput(ns("dates"), "Select start date:",format = "yyyy-mm-dd", startview = "month", value = dmy("1/1/2014")),
selectInput(ns("link"),"Select link ratio:",choices = list("All" = "all", "Standard" = "std"),selected = "all"),
conditionalPanel("input.link == 'std'", ns=ns, sliderInput(ns("std.month"),"No of months:",min=1,max=119,value=60))
)
}
ui <- shinyUI(
ui = dashboardPagePlus(skin = "red",
header = dashboardHeaderPlus(
title = "TITLE",
titleWidth = 700
),
dashboardSidebar(),
body = dashboardBody(
# boxPlus(
# width = NULL,title = "CHART",closable = TRUE,enable_sidebar = TRUE,
# sidebar_width = 15,sidebar_start_open = FALSE,sidebar_content = chartUI("chartui1"),
# highchartOutput("")
# ),
boxPlus(
width = NULL,title = "CHART",closable = TRUE,enable_sidebar = TRUE,
sidebar_width = 15,sidebar_start_open = FALSE,sidebar_content = chartUI("chartui2"),
highchartOutput("")
)
),
title = "DashboardPage"
)
)
server <- shinyServer(function(input, output) {
})
shinyApp(ui, server)
If I only call chartui2, conditional panel works fine. But if I call both chartui1 and chartui2, both of them no longer work.
A minimal example with uiOutput / renderUI would be:
library(shiny)
dyn_ui <- function(id) {
ns <- NS(id)
tagList(selectInput(ns("show"), "show or not", choices = c("hide", "show")),
uiOutput(ns("dyn")))
}
dyn_server <- function(input, output, session) {
output$dyn <- renderUI({
ns <- session$ns
if (input$show == "show") {
sliderInput(
inputId = ns("std_month"),
"No of months:",
min = 1,
max = 119,
value = 60
)
}
})
}
ui <- basicPage(dyn_ui("test"))
server <- function(input, output, session) {
callModule(module = dyn_server, id = "test")
}
runApp(list(ui = ui, server = server))
Edit:
In fact, a minimal example works well with conditionalPanel too (see below). So something else about your app is causing a conflict. Not sure what it is, but I would start adding components one by one and see when these minimal examples start misbehaving.
library(shiny)
dyn_ui <- function(id) {
ns <- NS(id)
tagList(
selectInput(ns("show"), "show or not", choices = c("hide", "show")),
conditionalPanel(
ns = ns,
condition = "input.show == 'show'",
sliderInput(
inputId = ns("std_month"),
"No of months:",
min = 1,
max = 119,
value = 60
)
)
}
ui <- basicPage(
dyn_ui("test"),
dyn_ui("test2")
)
server <- function(input, output, session) {
}
runApp(list(ui = ui, server = server))
Related
I'd like to use shinyWidgets::materialSwitch instead of a checkbox in my app for an improved UI.
However, I can't seem to get materialSwitch to work when used with renderUI/uiOutput. The input displays properly but doesn't seem to register a click to "switch".
For the purposes of my app - I need this to be inside a renderUI.
Pkg Versions:
shinyWidgets_0.7.2
shiny_1.7.2
library(shiny)
library(shinyWidgets)
# library(shinyjs)
ui <- fluidPage(
div(class="row",
column(width = 3,
uiOutput("switch")
)
)
)
server <- function(input, output, session) {
output$switch = renderUI({
materialSwitch(
inputId = "switch",
label = "Show Count",
right = TRUE,
status = "primary",
value = FALSE
)
})
}
shinyApp(ui = ui, server = server)
Why is this happening, and how can the problem be fixed?
The issue is that you give same name "switch" to both uiOutput.outputId and materiaSwitch.inputId.
It works OK when they get different ids:
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
div(class="row",
column(width = 3,
uiOutput("switch"),
textOutput("result")
)
)
)
server <- function(input, output, session) {
output$switch = renderUI({
materialSwitch(
inputId = "switchButton",
label = "Show Count",
right = TRUE,
status = "primary",
value = FALSE
)
})
output$result = renderText(input$switchButton)
}
shinyApp(ui = ui, server = server)
Here is how it should work:
library(shiny)
library(shinyWidgets)
# library(shinyjs)
ui <- fluidPage(
div(style = 'position: absolute;left: 50px; top:100px; width:950px;margin:auto',
materialSwitch(inputId = "switch",
label = "Show Count",
right = TRUE,
status = "primary",
value = FALSE)
)
)
server <- function(input, output, session) {
output$value1 <- renderText({ input$switch })
}
shinyApp(ui = ui, server = server)
Consider the following example application:
library(shiny)
library(shinyWidgets)
module_UI <- function(id){
tagList(
div(
uiOutput(
outputId = NS(id, "selection")
),
shinyWidgets::dropdown(
uiOutput(outputId = NS(id, "new_option")),
style = "unite",
label = "New",
color = "primary",
animate = animateOptions(
enter = animations$fading_entrances$fadeInLeftBig,
exit = animations$fading_exits$fadeOutRightBig
),
up = F,
width = "600px",
inline = T
)
)
)
}
module_server <- function(id){
moduleServer(id, function(input, output, session){
ns <- session$ns
return_values <- reactiveValues(selection=NULL)
output$selection <- renderUI({
selectInput(inputId = ns("selection"), label = "Select:", choices = 1:5)
})
output$new_option <- renderUI({
div(
numericInput(ns("new_option_input"), label = "Add a new option:"),
shinyWidgets::actionBttn(
inputId = ns("submit_new_option"),
label = "Submit",
icon = icon("paper-plane"))
)
})
observeEvent(input$submit_new_option, {
#does not work as intended
updateSelectInput(session = session, inputId = "selection", selected = input$new_option_input)
})
observe({
return_values$selection <- input$selection
})
return(return_values)
})
}
# Define UI for application that draws a histogram
ui <- fluidPage(
title = "Test App",
module_UI("test"),
verbatimTextOutput(outputId = "selection_chosen")
)
# Define server logic required to draw a histogram
server <- function(input, output) {
picker <- module_server("test")
output$selection_chosen <- renderText({
picker$selection
})
}
# Run the application
shinyApp(ui = ui, server = server)
Basically, the module should do two things:
Allow user to select a pre-existing option --> return that value from module
Allow user to create their own, new option --> return that value from module
I have #1 working, but am struggling on #2. Specifically, where I have the "does not work" comment. How can I achieve this functionality? What are/is the best practice(s) for returning server-side created values from a Shiny module? This is an example app; the real one involves reading the selectInput options from a database, as well as saving the newly created options in the database. Appreciate any help on this! A lot of SO answers regarding Shiny modules have the older callModule(...) syntax, which makes researching this topic a bit more confusing.
You just need to provide the default value in numericInput. Perhaps you are looking for this.
library(shiny)
library(shinyWidgets)
module_UI <- function(id){
ns <- NS(id)
tagList(
div(
uiOutput(
outputId = NS(id, "selection")
),
shinyWidgets::dropdown(
uiOutput(outputId = NS(id, "new_option")),
style = "unite",
label = "New",
color = "primary",
animate = animateOptions(
enter = animations$fading_entrances$fadeInLeftBig,
exit = animations$fading_exits$fadeOutRightBig
),
up = F,
width = "600px",
inline = T
),
DTOutput(ns("t1"))
)
)
}
module_server <- function(id){
moduleServer(id, function(input, output, session){
ns <- session$ns
return_values <- reactiveValues(selection=NULL,myiris = iris)
output$selection <- renderUI({
selectInput(inputId = ns("selection"), label = "Select:", choices = 1:5)
})
output$new_option <- renderUI({
tagList(
numericInput(ns("new_option_input"), label = "Add a new option:",10, min = 1, max = 100),
shinyWidgets::actionBttn(
inputId = ns("submit_new_option"),
label = "Submit",
icon = icon("paper-plane"))
)
})
observeEvent(input$submit_new_option, {
return_values$myiris <- iris[1:input$new_option_input,]
#does work as intended
updateSelectInput(session = session, inputId = "selection", choices= c(1:input$new_option_input), selected = input$new_option_input)
})
output$t1 <- renderDT({return_values$myiris})
observe({
return_values$selection <- input$selection
})
return(return_values)
})
}
# Define UI for application that draws a histogram
ui <- fluidPage(
title = "Test App",
module_UI("test"),
verbatimTextOutput(outputId = "selection_chosen"),
DTOutput("t2")
)
# Define server logic required to draw a histogram
server <- function(input, output) {
picker <- module_server("test")
output$selection_chosen <- renderText({
picker$selection
})
output$t2 <- renderDT({picker$myiris[,c(3:5)]})
}
# Run the application
shinyApp(ui = ui, server = server)
I am trying to create a conditional UI in Shiny that depends on the input of a user. I specifically want to do the if in the UI part and NOT in the server part.
Here is an example of what I aim to accomplish.
# app.R
library(shiny)
ui <- shiny::fluidPage(
shiny::headerPanel(title = "Basic App"),
shiny::sidebarPanel(
shiny::sliderInput(inputId = "a",
label = "Select an input to display",
min = 0, max = 100, value = 50
)
),
if(output$out < 50){
shinyjs::hide(shiny::mainPanel(h1(textOutput("text"))))
}else{
shiny::mainPanel(h1(textOutput("text")))
}
)
server <- function(input, output) {
output$text <- shiny::renderText({
print(input$a)
})
var <- shiny::reactive(input$a)
output$out <- renderText({ var() })
}
shiny::shinyApp(ui = ui, server = server)
Is there a way that I can use the reactive value in the UI part of the function?
I think conditionalPanel could be a good solution for what you want to do
library(shiny)
ui <- shiny::fluidPage(
shiny::headerPanel(title = "Basic App"),
shiny::sidebarPanel(
shiny::sliderInput(inputId = "a",
label = "Select an input to display",
min = 0, max = 100, value = 50
)
),
shiny::mainPanel(
conditionalPanel(
condition = "input.a > 50",
h1(textOutput("text")))
)
)
server <- function(input, output) {
output$text <- shiny::renderText({
print(input$a)
})
}
shiny::shinyApp(ui = ui, server = server)
Hope this helps!!
Thank you in advance for your help. I've tried to boil my issue down into as simple of an app as I could construct. I have a function sliderResetInput that calls an observeEvent and returns some UI elements. I can use sliderResetInput outside of a module (will demonstrate below), but I cannot use it inside a module. I thought this was an issue with a wrapping a namespace around my inputs, but I think the ID's all check out here. What's going on? As a note, while this construction seems needlessly complicated for this app, I need the structure for a much larger app.
This works:
library(shiny) # Version 1.0.5
sliderResetInput = function(id, input, output, session) {
observeEvent(input[[paste0(id, "_reset_slider")]],
updateSliderInput(session = session, inputId = paste0(id, "_slider"), value = c(0, 10)))
out = list(
sliderInput(inputId = paste0(id, "_slider"), label = "Slider", min = 0, max = 10, value = c(0, 10)),
actionButton(inputId = paste0(id, "_reset_slider"), label = "Reset slider")
)
return(out)
}
server <- function(input, output, session) {
getSliders = reactive(sliderResetInput(id = "test1", input, output, session))
output$sliders = renderUI(getSliders())
observeEvent(input$browser, browser())
}
ui <- fluidPage(
uiOutput(outputId = "sliders"),
actionButton(inputId = "browser", "Click me to go into browser()")
)
shinyApp(ui = ui, server = server, options = list(launch.browser = T))
With the same sliderResetInput() function, this does NOT work:
library(shiny) # Version 1.0.5
sliderResetInput = function(id, input, output, session) {
observeEvent(input[[paste0(id, "_reset_slider")]],
updateSliderInput(session = session, inputId = paste0(id, "_slider"), value = c(0, 10)))
out = list(
sliderInput(inputId = paste0(id, "_slider"), label = "Slider", min = 0, max = 10, value = c(0, 10)),
actionButton(inputId = paste0(id, "_reset_slider"), label = "Reset slider")
)
return(out)
}
myModuleUI = function(id) {
ns = NS(id)
tagList(
uiOutput(outputId = ns("sliders"))
)
}
myModule = function(input, output, session) {
ns = session$ns
getSliders = reactive(sliderResetInput(id = ns("test1"), input, output, session))
output$sliders = renderUI(getSliders())
}
server <- function(input, output, session) {
callModule(myModule, id = "A")
observeEvent(input$browser, browser())
}
ui <- fluidPage(
myModuleUI(id = "A"),
actionButton(inputId = "browser", "Click me to go into browser()")
)
shinyApp(ui = ui, server = server, options = list(launch.browser = T))
Does anyone know what's going on here?
Thank you for your time!
You have to prefix the ids of the widgets only. That is:
sliderResetInput = function(id, NSid, input, output, session) {
observeEvent(input[[paste0(id, "_reset_slider")]], {
updateSliderInput(session = session, inputId = paste0(id, "_slider"), value = c(0, 10))
})
out = list(
sliderInput(inputId = paste0(NSid, "_slider"), label = "Slider", min = 0, max = 10, value = c(0, 10)),
actionButton(inputId = paste0(NSid, "_reset_slider"), label = "Reset slider")
)
return(out)
}
and
getSliders = reactive(sliderResetInput(id = "test1", NSid = ns("test1"), input, output, session))
I've been searching around and cannot find an answer to my question. I've constructed a simple app to demonstrate my problem. Basically, the problem is that I am trying to use a renderUI inside my module server to conditionally create a uiOutput in the module UI. I've included a few print statements that lead me to believe that the renderUI is evaluated without input being updated. It is killing me that I can't figure this out, and I'd appreciate any help possible!
Example code:
library(shiny) # shiny_1.0.0
library(DT) # DT_0.2
testModuleUI <- function(id) {
ns = NS(id)
tagList(
br(),
sidebarPanel(width = 12, id = "inputBar",
fluidRow(
column(width = 2, checkboxInput(ns("buttonA"), label = "Button A", value = F)),
column(width = 2, uiOutput(ns("getButtonB")))
),
dataTableOutput(outputId = ns("tableOutput"))
)
)
}
testModule <- function(input, output, session, showB = F ){
ns = session$ns
output$getButtonB <- renderUI({
if( showB ){
print("call checkboxInput")
checkboxInput(ns("buttonB"), label = "Button B", value = F)
}else{
NULL
}
})
getTable <- reactive({
print("inside getTable")
out = c()
if( input$buttonA ) {
out = paste0(out, "A")
}
if( input$buttonB ){
out = paste0(out, "B")
}
data.frame(var = out)
})
output$tableOutput <- renderDataTable({
print("call getTable")
datatable( getTable() )
})
}
server <- function(input, output, session) {
callModule( module = testModule, id = "test1", showB = T )
session$onSessionEnded( stopApp )
}
ui <- pageWithSidebar(
headerPanel( title = "Test app" ),
sidebarPanel(
width = 3,
selectInput(inputId = "whatever", label = "This button doesn't matter", choices = c("A", "B"))
),
mainPanel(
tabsetPanel(
tabPanel("Tab 1", testModuleUI("test1"))
)
)
)
shinyApp( ui = ui, server = server, options = list(launch.browser = T)
)
Thank you!!