Friends could help me make my conditionalPanel functional. I made a conditionalPanel however I don't know how to adjust it on the server. When I press the option "No" I would like it to show the sliderInput ("Slider2"). The executable code is below. Thank you!
library(shiny)
ui <- shiny::navbarPage(
title = div(tags$img(src="", align="right", height='50px')),
sidebarLayout(
sidebarPanel(
sliderInput("Slider1",
"Number of bins:",
min = 1,
max = 50,
value = 30)
),
sidebarLayout(
sidebarPanel(
radioButtons("filter1","", choices = list("Yes" = 1,"No " = 2),selected = 1),
conditionalPanel(
"input.filter1 == 'No'",
sliderInput("Slider2",
"Number of bins:",
min = 1,
max = 20,
value = 30)),
),
mainPanel(
plotOutput("distPlot1")
))))
server <- function(input, output) {
output$distPlot1 <- renderPlot({
# generate bins based on input$bins from ui.R
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$Slider1 + 1)
# draw the histogram with the specified number of bins
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
}
# Run the application
shinyApp(ui = ui, server = server)
When you do
radioButtons("filter1", "", choices = list("Yes" = 1,"No " = 2)
the values of the radio buttons are "1" and "2", while "Yes" and "No" are the labels of the radio buttons. So you condition should be "input.filter1 == '2'".
Your condition must be "input.filter1 == 2" and not "input.filter1 == 'No'".
"No" is the name of the element, while 2 is the value (that is evaluated).
It will work with this modification.
Related
I am trying to create a dynamic UI that has variable number of user inputs based on a user input and charts that uses that second level of user input.
A working example below:
library(shiny)
ui <- fluidPage(
titlePanel("Old Faithful Geyser Data"),
numericInput(inputId = "Chartcount",
label = "Enter number of charts",
value = 5,
min = 2,
max = 8),
uiOutput("distui")
)
server <- function(input, output) {
c_count = reactive({input$Chartcount})
output$distui <- renderUI({
lapply(seq(1:c_count()), function(x){
chartId = (paste("Chart",x, sep = "="))
sinput <- sliderInput(inputId = paste(x,"_bins"),
"Number of bins:",
min = 1,
max = 50,
value = 30)
selectedbins = input[[paste(x,"_bins")]] # input$inputId does not work here as expression after $ can not be evaluated
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = 25 ) #I want to use selectedbins here for length.out
distplot <- renderPlot(hist(x, breaks = bins, col = 'darkgray', border = 'white'))
list(chartId, sinput,selectedbins, distplot)
})
})
}
shinyApp(ui = ui, server = server)
I think there are at least a couple of problems with this.
Selected number of bins resets as soon as they are selected
I get an error when I try to use selectedbins in the chart for
length.out
bins <- seq(min(x), max(x), length.out = selectedbins ) # This throws an error Error: argument 'length.out' must be of length 1
The selected number of bins is resetting because it is inside of the same reactive expression, you should put it in a different reactive expression, otherwise the full expression is going to be executed every time you change the input and it is going to recreate all the inputs and plots.
The second problem is caused because you are trying to use the selectedbins input value before the slider is created, therefore the value is NULL (length 0), you can only get the value after the slider is created.
Below is your code modified to create the plots in a separated reactive expression as a nested expression, maybe not the best solution but it is in the same style that your program. Also, reusing the x variable is confusing, so I changed the first one by k.
library(shiny)
ui <- fluidPage(
titlePanel("Old Faithful Geyser Data"),
numericInput(inputId = "Chartcount",
label = "Enter number of charts",
value = 5,
min = 2,
max = 8),
uiOutput("distui")
)
server <- function(input, output) {
output$distui <- renderUI({
lapply(seq(1:input$Chartcount), function(k){
chartId = (paste("Chart", k, sep = "="))
sinput <- sliderInput(inputId = paste(k, "bins_"),
"Number of bins:",
min = 1,
max = 50,
value = 30)
x <- faithful[, 2]
distplot <- tagList(
renderUI({
selectedbins = input[[paste(k, "bins_")]]
bins <- seq(min(x), max(x), length.out = selectedbins )
tagList(
selectedbins,
renderPlot(hist(x, breaks = bins, col = 'darkgray', border = 'white'))
)
})
)
list(chartId, sinput, distplot)
})
})
}
shinyApp(ui = ui, server = server)
Friends, is it possible to change the color tone of a shinytheme used? In my case I am using "united" which uses orange and gray. However I would like to make a slightly darker orange, is it possible to make this change? If so, can you please help me? The executable code is below.
library(shinyBS)
library(shiny)
library(shinyjs)
ui <- fluidPage(
navbarPage(theme = shinytheme("united"), collapsible = TRUE,
titlePanel("Old Faithful Geyser Data"),
sidebarLayout(
sidebarPanel(
radioButtons("filter1", h3("Select properties"),
choices = list("All properties" = 1,
"Exclude properties" = 2),
selected = 1),
title= "Select Proprierties",
radioButtons("filter2", h3("Select farms"),
choices = list("All farms" = 1,
"Exclude farms" = 2),
selected = 1),
sliderInput("bins",
"Number of bins:",
min = 1,
max = 20,
value = 30),
## need to include at least one bs element, adapt
bsTooltip("bins", "The wait times will be broken into this many equally spaced bins",
"right", options = list(container = "body"))
),
mainPanel(
plotOutput("distPlot")
)
)
))
## use JS to add an id attribute to the elements where you want to add the popover
add_id_js <- paste0(
"$('#filter1').find('.radio > label').attr('id', function(i) {",
"return 'filter1_row_' + i})")
server <- function(input, output, session) {
## once the UI is loaded, call JS function and attach popover to it
session$onFlushed(function() {
runjs(add_id_js)
addPopover(session, "filter1_row_0", "My Popover", "Content")
})
output$distPlot <- renderPlot({
# generate bins based on input$bins from ui.R
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
# draw the histogram with the specified number of bins
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
}
# Run the application
shinyApp(ui = ui, server = server)
Thank you very much friends!!
I know that it is a quite old question, but since there is no answer and I had the same problem, I wanted to add the solution that I found.
When I was trying to do the same for ShinyDashboard, I found this post. However, taking a look of what the fresh package can do, I found the way to solve your problem using navBarPage.
You just have to add this to your code:
# This is to create your own theme. Depending on your needs, you can remove or keep some options.
mytheme <- create_theme(
theme = "default",
bs_vars_navbar(
default_bg = "#75b8d1",
default_color = "#FFFFFF",
default_link_color = "#FFFFFF",
default_link_active_color = "#75b8d1",
default_link_active_bg = "#FFFFFF",
default_link_hover_color = "firebrick"
),
output_file = NULL
)
navbarPage(
title = "Custom navbar",
header = tagList(
use_theme(mytheme) # <-- use your theme
),
tabPanel("Tab 1"),
tabPanel("Tab 2")
)
Just a note that when I load your code I get this warnings:
Warning messages: 1: In sliderInput(): value should be less than or
equal to max (value = 30, max = 20). 2: Navigation containers
expect a collection of bslib::nav()/shiny::tabPanel()s and/or
bslib::nav_menu()/shiny::navbarMenu()s. Consider using header or
footer if you wish to place content above (or below) every panel's
contents.
So, in order to try the code that I added you, I fixed them.
library(shinyBS)
library(shiny)
library(shinyjs)
library(fresh)
# This is to modify the header background color. It uses fresh package.
mytheme <- create_theme(
adminlte_color(
light_blue = "#9d6708"
)
)
mytheme <- create_theme(
theme = "default",
bs_vars_navbar(
default_bg = "#9d6708",
),
output_file = NULL
)
ui <- fluidPage(
navbarPage(
title = "Old Faithful Geyser Data",
collapsible = TRUE,
header = tagList(
use_theme(mytheme) # <-- use your theme
),
tabPanel(
title = "Tab 1",
sidebarLayout(
sidebarPanel(
radioButtons("filter1", h3("Select properties"),
choices = list("All properties" = 1,
"Exclude properties" = 2),
selected = 1),
title= "Select Proprierties",
radioButtons("filter2", h3("Select farms"),
choices = list("All farms" = 1,
"Exclude farms" = 2),
selected = 1),
sliderInput("bins",
"Number of bins:",
min = 1,
max = 30,
value = 20),
## need to include at least one bs element, adapt
bsTooltip("bins", "The wait times will be broken into this many equally spaced bins",
"right", options = list(container = "body"))
),
mainPanel(
plotOutput("distPlot")
)
)
))
)
## use JS to add an id attribute to the elements where you want to add the popover
add_id_js <- paste0(
"$('#filter1').find('.radio > label').attr('id', function(i) {",
"return 'filter1_row_' + i})")
server <- function(input, output, session) {
## once the UI is loaded, call JS function and attach popover to it
session$onFlushed(function() {
runjs(add_id_js)
addPopover(session, "filter1_row_0", "My Popover", "Content")
})
output$distPlot <- renderPlot({
# generate bins based on input$bins from ui.R
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
# draw the histogram with the specified number of bins
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
}
# Run the application
shinyApp(ui = ui, server = server)
I don't know what type of orange you wanted, but I changed to this tone #9d6708 just to show you the difference.
Here you have more info if you want to check about the fresh package and using NavbarPage.
Friends I have two questions and I would like your help: First, I would like to separate my two filters and the sliderInput on the panel. They are all together. I would like to leave them separated by some horizontal line or by a specific tag that makes this separation. The second is that I am using popify to describe the filters used. In this case, I am used radioButtons. However, I would like to do it separately for the filter options. For example, for filter 1, I would like to insert popify for the "All properties" and "exclude properties" options as well. So, separate three popify for the same filter, is this possible ?? The executable code is below.
library(shinyBS)
library(shiny)
ui <- fluidPage(
titlePanel("Old Faithful Geyser Data"),
sidebarLayout(
sidebarPanel(
popify(
radioButtons("filter1", h3("Select properties"),
choices = list("All properties" = 1,
"Exclude properties" = 2),
selected = 1),
title= "Select Proprierties",
content = paste0("Filter 1 refers to.....")),
popify(
radioButtons("filter2", h3("Select farms"),
choices = list("All farms" = 1,
"Exclude farms" = 2),
selected = 1),
title= "Select farms",
content = paste0("Filter 2 refers to.....")),
popify(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 20,
value = 30),
title = "Number of bins",
content = paste0("Number of bins refers to.....")),
),
mainPanel(
plotOutput("distPlot")
)
)
)
server <- function(input, output) {
output$distPlot <- renderPlot({
# generate bins based on input$bins from ui.R
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
# draw the histogram with the specified number of bins
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
}
# Run the application
shinyApp(ui = ui, server = server)
Thank you very much!!
Here is a way. It uses JavaScript to assign an id to each radio button. Then addPopover can be used.
js <- "
$(document).ready(function(){
$('#dist input[type=radio]~span').each(function(i, $el){
$(this).attr('id', 'dist' + i);
});
});
"
library(shiny)
library(shinyBS)
ui <- fluidPage(
tags$head(tags$script(HTML(js))),
radioButtons("dist", "Distribution type:",
c("Normal" = "norm",
"Uniform" = "unif",
"Log-normal" = "lnorm",
"Exponential" = "exp")),
plotOutput("distPlot"),
popify(span(), title = "") # an empty shinyBS component, in order to use addPopover
)
server <- function(input, output, session) {
output$distPlot <- renderPlot({
dist <- switch(input$dist,
norm = rnorm,
unif = runif,
lnorm = rlnorm,
exp = rexp,
rnorm)
hist(dist(500))
})
addPopover(
session,
id = "dist0",
title = "Normal distribution",
content = "It is also called the Gaussian distribution",
placement = "right"
)
addPopover(
session,
id = "dist1",
title = "Uniform distribution",
content = "All outcomes are equally probable",
placement = "right"
)
addPopover(
session,
id = "dist2",
title = "Log-normal distribution",
content = "The exponential of the normal distribution",
placement = "right"
)
addPopover(
session,
id = "dist3",
title = "Exponential distribution",
content = "It is memoryless",
placement = "right"
)
}
shinyApp(ui, server)
You have to change the JS code according to the inputId of your radio buttons group, and to set the prefix of the generated ids to the one you want:
js <- "
$(document).ready(function(){
$('#YOUR_inputId_GOES_HERE input[type=radio]~span').each(function(i, $el){
$(this).attr('id', 'THE_PREFIX_YOU_WANT' + i);
});
});
"
This generated the ids THE_PREFIX_YOU_WANT0, THE_PREFIX_YOU_WANT1, etc. To be used in addPopover:
addPopover(session, id = "THE_PREFIX_YOU_WANT0", ......)
I am trying to implement into.js multipage functionality on a Shiny app.
The code bellow is an attempt that does not work. The first tab works nicely, the popup for the second page is displayed but without switching the tab.
ui.R
library(shiny)
shinyUI(tagList(
tags$head(
HTML("<link rel='stylesheet' type='text/css' href='css/introjs.min.css'>")
),
navbarPage("Old Faithful Geyser Data",
tabPanel(id = "fTab", "First tab",
HTML("<h1 data-step='1' data-intro='This is a tooltip!'>Basic Usage</h1>"),
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30),
plotOutput("distPlot"),
HTML("<a id='startButton' class='btn btn-large btn-success' href='javascript:void(0);'>Help</a>")
),
tabPanel(tabName = "sTab", "Second tab", id = "tt",
HTML("<h1 data-step='2' data-intro='This is a second tooltip!'>Basic Usage</h1>"),
sliderInput("bins2",
"Number of bins:",
min = 1,
max = 50,
value = 30),
plotOutput("distPlot2")
)
),
HTML("<script type='text/javascript' src='js/intro.min.js'></script>"),
HTML("<script type='text/javascript'>document.getElementById('startButton').onclick = function() {
introJs().setOption('doneLabel', 'Next page').start().oncomplete(function() {
window.location.hash = '#!tt?multipage=true';
});
};</script>")
))
server.R
library(shiny)
shinyServer(function(input, output) {
output$distPlot <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
output$distPlot2 <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins2 + 1)
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
})
The js and css files from intro.js are in the js and css folders inside the www folder. The intro.js files may be found here
My guess is that I am doing something wrong in the function in the javascript code at the bottom of ui.R. I have tried to adapt the example from here by replacing the window.location.href with window.location.hash and referencing the tab id which is "tt".
#warmoverflow gave an excellent answer. Here is a version of the same answer using rintrojs:
library(shiny)
library(rintrojs)
ui = shinyUI(tagList(
introjsUI(),
navbarPage(
"Old Faithful Geyser Data",
tabPanel(
id = "fTab",
"First tab",
introBox(
h1("Basic Usage"),
data.step = 1,
data.intro = "This is a tooltip"
),
sliderInput(
"bins",
"Number of bins:",
min = 1,
max = 50,
value = 30
),
plotOutput("distPlot"),
actionButton("startButton", "Help")
),
tabPanel(
tabName = "sTab",
"Second tab",
id = "tt",
introBox(
h1("Basic Usage 2"),
data.step = 2,
data.intro = "This is a second tooltip"
),
sliderInput(
"bins2",
"Number of bins:",
min = 1,
max = 50,
value = 30
),
plotOutput("distPlot2")
)
)
))
server = shinyServer(function(input, output, session) {
output$distPlot <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
hist(x,
breaks = bins,
col = 'darkgray',
border = 'white')
})
output$distPlot2 <- renderPlot({
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins2 + 1)
hist(x,
breaks = bins,
col = 'darkgray',
border = 'white')
})
observeEvent(input$startButton, {
introjs(
session,
events = list(
"onchange" = "if (this._currentStep==0) {
$('a[data-value=\"Second tab\"]').removeClass('active');
$('a[data-value=\"First tab\"]').addClass('active');
$('a[data-value=\"First tab\"]').trigger('click');
}
if (this._currentStep==1) {
$('a[data-value=\"First tab\"]').removeClass('active');
$('a[data-value=\"Second tab\"]').addClass('active');
$('a[data-value=\"Second tab\"]').trigger('click');
}"
)
)
})
})
shinyApp(ui = ui, server = server)
The tabs don't switch if you go back to the first step of the tour though, so the code only works going forwards through the tour.
NOTE: in rintrojs version 0.1.2.900 and higher, raw javascript needs to be wrapped in I()
Here is the working solution. Note that you need to
Determine the current step to switch tabs. The multi page example does not apply here, as all your steps are on one page (multiple tabs but one page), thus intro.js will display all steps before next page is clicked
Use JavaScript/JQuery to simulate the tab click event.
ui.R (server.R unchanged)
library(shiny)
shinyUI(tagList(
tags$head(
HTML("<link rel='stylesheet' type='text/css' href='css/introjs.min.css'>")
),
navbarPage("Old Faithful Geyser Data",
tabPanel(id = "fTab", "First tab",
HTML("<h1 data-step='1' data-intro='This is a tooltip!'>Basic Usage</h1>"),
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30),
plotOutput("distPlot"),
HTML("<a id='startButton' class='btn btn-large btn-success' href='javascript:void(0);'>Help</a>")
),
tabPanel(tabName = "sTab", "Second tab", id = "tt",
HTML("<h1 data-step='2' data-intro='This is a second tooltip!'>Basic Usage</h1>"),
sliderInput("bins2",
"Number of bins:",
min = 1,
max = 50,
value = 30),
plotOutput("distPlot2")
)
),
HTML("<script type='text/javascript' src='js/intro.min.js'></script>"),
HTML("<script type='text/javascript'>document.getElementById('startButton').onclick = function() {
introJs().onchange(function(targetElement) {
if (this._currentStep==0) {
$('a[data-value=\"Second tab\"]').removeClass('active');
$('a[data-value=\"First tab\"]').addClass('active');
$('a[data-value=\"First tab\"]').trigger('click');
}
if (this._currentStep==1) {
$('a[data-value=\"First tab\"]').removeClass('active');
$('a[data-value=\"Second tab\"]').addClass('active');
$('a[data-value=\"Second tab\"]').trigger('click');
}
}).start();
};</script>")
))
I have a side bar as follows
sidebarPanel(
wellPanel(
list(tags$head(tags$style("body {background-color: #E0F2F7; }"))),
helpText("Choose a stock ticker to examine, For example
^HSI - Hang Seng,
^N225 - Nikkei 225 and
^FTSE - FTSE 100.
Information will be collected from",tags$a(href="https://uk.finance.yahoo.com/lookup", "yahoo finance"),"."),
textInput("symb", "Symbol", "^FTSE"),
bsAlert(inputId = "alert_anchor"),
dateRangeInput("dates",
"Date range",
start = "2015-01-01",
end = as.character(Sys.Date())),
textOutput("DateRange"),
div(style="display:inline-block",submitButton("Analysis")),
div(style="display:inline-block",downloadButton('downloadData', 'Download Data')),width=6
))
Which gives the following (side bar is on the left)
However I wanted it so that the sidebar follows the page as the user scrolls up and down instead of there being a blank blue space on the left as shown.
Is this possible to do on R Shiny? If so, how can it be done?
You can add a style argument to sidebarPanel, which sets the element position to fixed. Below is the Shiny default minimal example with minor modifications to illustrate the behavior.
library(shiny)
ui <- fluidPage(
titlePanel("Hello Shiny!"),
sidebarLayout(
sidebarPanel(
style = "position:fixed; width:33%;", # Add this line to your code!
sliderInput(inputId = "bins",
label = "Number of bins:",
min = 1,
max = 50,
value = 30)
),
mainPanel(
lapply(1:10, function(i) {
plotOutput(outputId = paste("distPlot", i, sep = "_"))
})
)
)
)
server <- function(input, output) {
lapply(1:10, function(i) {
output[[paste("distPlot", i, sep = "_")]] <- renderPlot({
set.seed(i)
x <- rnorm(n = 1000)
bins <- seq(min(x), max(x), length.out = input$bins + 1)
hist(x, breaks = bins, col = "#75AADB", border = "white",
xlab = "Waiting time to next eruption (in mins)",
main = "Histogram of waiting times")
})
})
}
shinyApp(ui = ui, server = server)