I know there are a few posts about this issue, but I'm not getting why my code is not working. I have an app in Shiny that I'd like to have contain a conditional sidebar panel, that shows different controls based on which panel in the main panel is currently selected by the user. I thought the code below would work, but the app only displays conditional panel 1 (as defined below). Can anyone give me any advice? Thanks.
my ui.R:
library(shiny)
shinyUI(pageWithSidebar(
# Application title
headerPanel("Spatially Balanced Sampling Tool"),
sidebarPanel(
tags$head(
tags$style(type="text/css", "select { max-width: 175px; }"),
tags$style(type="text/css", "textarea { max-width: 100px; }"),
tags$style(type="text/css", ".jslider { max-width: 120px; }"),
tags$style(type='text/css', ".well { max-width: 200px; }"),
tags$style(type='text/css', ".span4 { max-width: 200px; }")
),
conditionalPanel(condition="input.conditionedPanels == 1",
fileInput('file1', 'Choose .ZIP Shapefile:', multiple=TRUE,
accept=c('binary'))
),
conditionalPanel(condition="input.conditionedPanels == 2",
numericInput("pts", "# of sampling points per stratum:", 50),
numericInput("oversamppts", "# to OVER sample (optional):", 5),
submitButton("Generate Points"),
helpText("WORK DAMMIT")
)),
mainPanel(
tabsetPanel(
tabPanel("Instructions",
includeHTML("instructions.html"),
div(id="linkToMap", tags$a("Click here to see a map of your input data and create points")),
div(id="linkToPoints", tags$a("Click here to see table of created points")),
value=1
),
tabPanel("plot", helpText("Map of input polygons"),
plotOutput("plot"),
p(paste("polygons by strata")),
value=2
),
tabPanel("View Points", helpText("suggested sampling points"),
tableOutput("pointdata"),
HTML("<script>$('#linkToMap').click(function() {
tabs = $('.tabbable .nav.nav-tabs li')
tabs.each(function() {
$(this).removeClass('active')
})
$(tabs[1]).addClass('active')
tabsContents = $('.tabbable .tab-content .tab-pane')
tabsContents.each(function() {
$(this).removeClass('active')
})
$(tabsContents[1]).addClass('active')
$('#plot').trigger('change').trigger('shown')
})</script>
"),
HTML("<script>$('#linkToPoints').click(function() {
tabs = $('.tabbable .nav.nav-tabs li')
tabs.each(function() {
$(this).removeClass('active')
})
$(tabs[2]).addClass('active')
tabsContents = $('.tabbable .tab-content .tab-pane')
tabsContents.each(function() {
$(this).removeClass('active')
})
$(tabsContents[2]).addClass('active')
$('#pointdata').trigger('change').trigger('shown')
})</script>
"),
value=2
),
id = "conditionedPanels"))))
It looks like the conditionalPanel statement is looking for the name of the tabPanel.
# This will not work
condition="input.conditionedPanels == 1" #wrong
When I switched the condition in your conditionalPanel statement to test for the name of the tab, as opposed to the value, it worked.
I scooped out everything extraneous and got your UI.R to work conditionally as intended. You can use this as a starting point and go from here.
UI.R
library(shiny)
shinyUI(pageWithSidebar(
headerPanel("Spatially Balanced Sampling Tool"),
sidebarPanel(
conditionalPanel(condition="input.conditionedPanels == 'Tab1'",
helpText("TAB 1")
),
conditionalPanel(condition="input.conditionedPanels == 'Tab2'",
helpText("TAB 2 SELECTED")
)
),
mainPanel(
tabsetPanel(
tabPanel("Tab1",
p(paste("Tab 1 text")
)
),
tabPanel("Tab2", helpText("Map of input polygons"),
p(paste("polygons by strata")
)
),
id = "conditionedPanels"
)
)
))
Related
In the below example code, I'd like each click of the "Add" button to add 1 to the value presented in the little "data" table underneath. Instead of the "Add" button, the code below has the "Test add" button working this way for demo purpose. I'd like to have "Add" do what "Test add" currently does, and then remove "Test add".
The "Show table" button works as it should: each click renders a larger table (unrelated, this is all a simple example) underneath. And the "Add" button works correctly in hiding the rendered larger table each time it is clicked; but I'd also like a click of "Add" to add 1 as described above.
In the below code I commented out observeEvent("input.show == 'Add'",{x(x()+1)}), which was my attempt to have a click of "Add" cause the addition of 1. How do I correct this, so the observeEvent() is essentially triggered by input.show == 'Add'?
This image helps explain:
Code:
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
br(),actionButton("add","Test add"), br(),br(),
radioGroupButtons(
inputId = "show",
label = NULL,
choices = c("Add","Show table"),
status = "primary",
selected = "Add"
),
br(),
fluidRow(tableOutput("data")),
fluidRow(
conditionalPanel(
"input.show == 'Show table'",
column(10,
column(4, h5(textOutput("text"))),
column(6, tableOutput("table")),
style = "border: 2px solid grey; margin-left: 15px;"
),
style = "display: none;"
)
)
)
server <- function(input, output, session) {
x = reactiveVal(0)
output$data <- renderTable(x())
output$table <- renderTable(iris[1:5, 1:3])
output$text <- renderText("Test show/hide in JS")
observeEvent(input$add,{x(x()+1)})
# observeEvent("input.show == 'Add'",{x(x()+1)})
}
shinyApp(ui, server)
One can easily watch show to create make the value increase by 1 every other time the "add" in show is clicked.
observeEvent(input$show, {
req(input$show == "Add")
x(x()+1)
})
The problem is that you have to click Show table once and then click Add, then the value will increase. If you continuously click Add, the value will only increase one time. To solve the problem, we can bind a new JS event to the Add button and send the value to R.
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
br(), br(), br(), br(),
radioGroupButtons(
inputId = "show",
label = NULL,
choices = c("Add","Show table"),
status = "primary",
selected = "Add"
),
tags$script(HTML(
"
$(()=>{
var clicks = 0;
$('#show button').first().on('click', ()=> {
clicks ++;
Shiny.setInputValue('add_button', clicks);
});
})
"
)),
br(),
fluidRow(tableOutput("data")),
fluidRow(
conditionalPanel(
"input.show == 'Show table'",
column(10,
column(4, h5(textOutput("text"))),
column(6, tableOutput("table")),
style = "border: 2px solid grey; margin-left: 15px;"
),
style = "display: none;"
)
)
)
server <- function(input, output, session) {
x <- reactiveVal(0)
output$data <- renderTable(x())
output$table <- renderTable(iris[1:5, 1:3])
output$text <- renderText("Test show/hide in JS")
observeEvent(input$add_button, {
x(input$add_button)
})
}
shinyApp(ui, server)
Alternative
If this value is only used to display how many times the button is clicked, or if you care about the performance, we can handle this job purely in JS, meaning no server interaction is required. If you have a great number of users, the following will help to decrease your server burden.
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
br(), br(), br(), br(),
radioGroupButtons(
inputId = "show",
label = NULL,
choices = c("Add","Show table"),
status = "primary",
selected = "Add"
),
tags$script(HTML(
"
$(()=>{
var clicks = 0;
$('#show button').first().on('click', ()=> {
clicks ++;
$('#data td').text(` ${clicks} `);
});
})
"
)),
br(),
fluidRow(tableOutput("data")),
fluidRow(
conditionalPanel(
"input.show == 'Show table'",
column(10,
column(4, h5(textOutput("text"))),
column(6, tableOutput("table")),
style = "border: 2px solid grey; margin-left: 15px;"
),
style = "display: none;"
)
)
)
server <- function(input, output, session) {
output$data <- renderTable(0)
output$table <- renderTable(iris[1:5, 1:3])
output$text <- renderText("Test show/hide in JS")
}
shinyApp(ui, server)
1 ) How can we position a selectInput next to an other one? I tried :
# style.css
.general {
display: inline-block;
margin-left: auto;
margin-right: auto;
height: auto;
width : auto ;
white-space: nowrap ;}
# ui.R
...
tags$div(class = "general", selectInput(...), selectInput(...))
...
but it doesn't work.
2) How can we position the label of a selectInput next to the selectInput itself ? I found this topic Positioning Shiny widgets beside their headers
but this is designed for all the selectInput of the app. I did not managed to use the code provided in tags$style(...) for only one selectInput of my app, not all of them. How can we do that ?
Thanks.
Just try using one fluid row and several columns. Since the total fluid row width = 12 you may put up to 12 columns one after another without any additional css. For example:
fluidRow(
column(6, selectInput("S1", label = "S1")),
column(6, selectInput("S2", label = "S2"))
)
I answer myself for question 1), with a simple example :
# style.css
.divleft {
float : left;
width : 50%;
}
.clearl {
clear: left;
}
# ui.R
library(shiny)
shinyUI(fluidPage(
tagList(
tags$head(
tags$link(rel="stylesheet", type="text/css",href="style.css")
)
),
sidebarLayout(
sidebarPanel(
selectInput("s1", "Select 1", 1:10),
tags$div(
tags$div(class = "divleft", selectInput("s2", label = "Select 2", 1:5, width = validateCssUnit("70%"))),
tags$div(class = "divleft", selectInput("s3", label = "Select 3", 1:5, width = validateCssUnit("70%")))
),
tags$div(class = "clearl",
selectInput("s4", "Select 4", 1:5)
)
, width = 3),
mainPanel(
h3("Example")
)
)
)
)
# server.R
shinyServer(function(input, output, session) { })
I've got a shiny application like this:
server.R:
library(shiny)
function(input, output) { NULL }
and ui.R:
library(shiny)
pageWithSidebar(
headerPanel("side-by-side"),
fluidRow(
column(2),
column(4,
wellPanel(
selectInput(inputId = "options", label = "some text",
choices = list(a = 0, b = 1)))
)
),
fluidRow(
h3("bla bla")
)
)
And I would like to have the label of selectInput next to it, not above. Do you know how to do it?
I've found this: Positioning Shiny widgets beside their headers
but it doesn't work for me.
There's multiple ways of doing this, here's one:
library(shiny)
server <- shinyServer(function(input, output) { NULL })
ui <- shinyUI(
pageWithSidebar(
headerPanel("side-by-side"),
sidebarPanel(
fluidRow(
tags$head(
tags$style(type="text/css", "label.control-label, .selectize-control.single{ display: table-cell; text-align: center; vertical-align: middle; } .form-group { display: table-row;}")
),
column(2),
column(4,
selectInput(inputId = "options", label = "some text",
choices = list(a = 0, b = 1))
)
)),
mainPanel(
fluidRow(
h3("bla bla")
))
)
)
shinyApp(ui=ui,server=server)
If you don't want to mess with shinys default CSS you can just leave the label empty and create a label next to it instead of forcing the existing label to the side.
How can I position Shiny widgets (e.g. the dropdown box of selectInput()) besides their headers? I've been playing around with various tags formulations without any luck. Grateful for any pointers.
ui.R
library(shiny)
pageWithSidebar(
headerPanel("side-by-side"),
sidebarPanel(
tags$head(
tags$style(type="text/css", ".control-label {display: inline-block;}"),
tags$style(type="text/css", "#options { display: inline-block; }"),
tags$style(type="text/css", "select { display: inline-block; }")
),
selectInput(inputId = "options", label = "dropdown dox:",
choices = list(a = 0, b = 1))
),
mainPanel(
h3("bla bla")
)
)
server.R
shinyServer(function(input, output) { NULL })
Is this what you want?
library(shiny)
runApp(list(ui = pageWithSidebar(
headerPanel("side-by-side"),
sidebarPanel(
tags$head(
tags$style(type="text/css", "label.control-label, .selectize-control.single{ display: inline-block!important; }")
),
selectInput(inputId = "options", label = "dropdown dox:",
choices = list(a = 0, b = 1))
),
mainPanel(
h3("bla bla")
)
)
, server = function(input, output) { NULL })
)
This is a simplification of my Shiny UI. My issue is that the pull-down menu from the SelectizeInput is hidden. It is a bit of a pain having to scroll down. Also, it just does not look very nice. I have tried playing with the z-index to bring it up front but have not had any success.
This is my code:
library(shiny)
runApp(list(
ui = fluidPage(
tabsetPanel(id = "tabs",
tabPanel("Search",
fluidRow(
column(12,
inputPanel(
selectizeInput("s1", h4("Select State:"),
choices = state.name),
tags$head(tags$style(".selectize-control.single { width: 400px; z-index: 1; }")),
dateInput("day", h4("Input Date:"), value = Sys.Date())
)
)
)
)
)),
server = function(input,output,session)
{
})
)
Basically, I want the SelectizeInput menu to display on top like the DateInput calendar.
Thanks for the help!
Carlos
You can use the options from the selectize.js library https://github.com/brianreavis/selectize.js/blob/master/docs/usage.md . dropdownParentmaybe what you are looking for:
library(shiny)
runApp(list(
ui = fluidPage(
tabsetPanel(id = "tabs",
tabPanel("Search",
fluidRow(
column(12,
inputPanel(
selectizeInput("s1", h4("Select State:")
, options = list(dropdownParent = 'body')
, choices = state.name),
tags$head(tags$style(".selectize-control.single { width: 400px; z-index: 1; }")),
dateInput("day", h4("Input Date:"), value = Sys.Date())
)
)
)
)
)),
server = function(input,output,session)
{
})
)
Alternatively you can look at CSS and something like the overflow attribute. See Dropdowns not extending in shiny tabPanel . So in this case use
tags$head(tags$style(".tab-content {overflow: visible;}")),