I want to hide a selectInput so it doesnt let people try and use it before the data has loaded.
Snippet of UI code.
ui <- dashboardPage(
dashboardHeader(title = "TCS Adverse Event Search Tool"),
dashboardSidebar(
sidebarMenu(
shinycssloaders::withSpinner(
selectInput("ingredients",
label = "Select one or more Active Ingredients:",
choices = NULL,
multi=TRUE)
),
In my server function I have this:
server <- function(input, output, session) {
# get main data frame
ingredients_df <- reactive({
ingredients_df <- read.csv(file="/projects/other/pv_compliance/active_ingredients.csv")
print(paste(nrow(ingredients_df)," active ingredient rows returned"))
return(ingredients_df)
})
cases_df <- reactive({
cases_df <- read.csv(file="/projects/other/pv_compliance/adverse_events.csv")
print(paste(nrow(cases_df)," case rows returned"))
return(cases_df)
})
observeEvent(ingredients_df(), {
updateSelectInput(session,
"ingredients",
choices = ingredients_df()$PRIMARY_SUSPECT_KEY_INGREDIENT,
selected = NULL
)
})
Two things are happening...
the set of widgets now appear about halfway down the sidebar and not the top
the css loader does not display when the updateSelectInput is getting the data
Related
I have a Shiny app with produces the following output. I would like the height of the graph to scale to fill the row which contains the sidebar, (down to some minimum dimension). This sidebar height changes depending on the data being examined.
The ui code I'm currently using is:
sidebarLayout(
sidebarPanel(
uiOutput("ridgeDates")
),
mainPanel(
plotOutput("ridgesPlot")
)
)
with the plot being rendered by renderPlot(...) This seems to adjust the /width/ automatically as I change the browser window width.
I've spent a while searching but can't find anything that does this. Is this possible?
We can use jQuery to track the height of the sidebar and set the height of the plot in css before creating the plotOutput. To do that, we need to use uiOutput in the UI, then render the plot dynamically.
So in the UI, the mainPanel will now have:
uiOutput("ridgePlot")
Then the plot is rendered in the server like so:
output$ridgePlot <- renderUI({
# plot data
output$ridges <- renderPlot({
# plot()
})
plotOutput("ridges")
})
Now we use shinyjs() to write a simple javascript function that sets the height value of the plot to the height of the sidebar. The sidebar is of class well, so we first get the height of the well, save it to a variable then set the ridges plot to the height of the variable, in javascript like this:
var newHeight = $('.well').outerHeight(); $('#ridges').height(newHeight)
I have used .outerHeight() because the well has extra padding that effectively gives it extra height than the height specified in the css rules for the well.
We can use this function in shiny using runjs() from shinyjs package. Since we need to get the height from the well after it has been rendered, we use observe and use it before the plotOutput inside the renderPlot, which is also inside the renderUI.
observe({
session$onFlushed(function() {
shinyjs::runjs("var newHeight = $('.well').outerHeight(); $('#ridges').height(newHeight)")
}, once=TRUE)
})
Putting it together in one Shiny app:
library(shiny)
library(shinyjs)
library(ggplot2)
ui = fluidPage(
useShinyjs(),
titlePanel("This is just a test!"),
sidebarLayout(
sidebarPanel(
uiOutput("ridgeDates")
),
mainPanel(
uiOutput("ridgePlot")
))
)
server = function(input, output, session) {
output$ridgeDates <- renderUI({
rng <- round(runif(1, 15, 21))
radioButtons("choose", "A changing list", choices = 1:rng)
})
output$ridgePlot <- renderUI({
datax <- matrix(c(1,2,3,4,5,6),6,1)
datay <- matrix(c(1,7,6,4,5,3),6,1)
titleplot<-"title"
summary <- "testing text"
output$ridges <- renderPlot({
# pl <- plot(datax, datay, main = titleplot, xlab = "input$axis1", ylab = "input$axis2", pch=18, col="blue")
ggplot(NULL, aes(datax, datay))+
geom_point(colour = "#1e90ff")
})
observe({
session$onFlushed(function() {
shinyjs::runjs("var newHeight = $('.well').outerHeight(); $('#ridges').height(newHeight)")
}, once=TRUE)
})
plotOutput("ridges")
})
}
# Run the application
shinyApp(ui = ui, server = server)
My example:
I saw some previous questions that may circle around this issue, but I couldn't find a clear answer to that.
My problem is that an ui element added using insertUI that depends on a reactive value does not update.
In the example I gave below, if one adds the new selectInput using the button and then changes the gender selection, the choices are updated only in the first selectInput.
The question is: is there an "official" way to make this selectInput reactive? I can imagine some workarounds, but they are not ideal.
server.R
library(shiny)
library(tidyverse)
server <- function(input, output, session) {
data <- reactive({
req(input$genderSelection)
starwars %>%
filter(gender == input$genderSelection)
})
output$characterSelection1 <- renderUI({
selectInput(
"char1",
"Character 1",
choices = data() %>%
.$name
)
})
observeEvent(
input$btn,
{
insertUI(
selector = "#selection2",
where = "beforeEnd",
ui = selectInput(
"char2",
"Character 2",
choices = data() %>%
.$name
)
)
}
)
}
ui.R
ui <- fluidPage(
radioButtons(
"genderSelection",
"Gender",
choices = c("male", "female")
),
uiOutput("characterSelection1"),
tags$div(
id = "selection2",
actionButton("btn", "Add selection")
)
)
I am trying filter my data using the dplyr package inside the reactive function in Shiny, but nothing is being displayed in the output. The data is supposed to be filtered by levels of the variable "Country".
Here is the code I have used and the dataframe
datos<-data.frame(time=c(rep(c(2001, 2002),3)), values=c(100,200,300,600,700,800), country=c(rep("Uruguay",2),rep("France",2),rep("United States",2)))
ui <- fluidPage(
selectInput(inputId ="pais", label="Choose a country",
choices =levels(datos$country), selected = "Uruguay"),
plotOutput(outputId ="barplot")
)
server <- function(input, output) {
datos3 <- reactive({
datos%>%
filter(country=="input$pais")
})
output$barplot<-renderPlot({
ggplot(datos3(),aes(x=time,y=values))+geom_bar(stat="Identity")
})
}
shinyApp(ui = ui, server = server)
I am supposed to obtain the values for the selected country, by time period.
You didn't need the quotation marks on "input$pais".
Here is the code with that and the extra + in the ggplot section removed.
library(shiny)
library(tidyverse)
datos<-data.frame(time=c(rep(c(2001, 2002),3)), values=c(100,200,300,600,700,800), country=c(rep("Uruguay",2),rep("France",2),rep("United States",2)))
ui <- fluidPage(
selectInput(inputId ="pais", label="Choose a country",
choices =levels(datos$country), selected = "Uruguay"),
plotOutput(outputId ="barplot")
)
server <- function(input, output) {
datos3 <- reactive({
datos%>%
filter(country==input$pais) #this bit has been changed
})
output$barplot<-renderPlot({
ggplot(datos3(),aes(x=time,y=values))+geom_bar(stat="Identity")
})
}
shinyApp(ui = ui, server = server)
How can I get the list of choices in a SelectInpute?
ui.R
selectInput(inputId = "select_gender",
label = "Gender",
choices = c("Male","Female"),
width = 150
)
server.R
# Something like...
genders <- input$select_gender["choices"]
# So that the gender would be:
> genders
[1] Male Female
From the scoping rules of Shiny:
Objects defined in global.R are similar to those defined in app.R outside of the server function definition, with one important difference: they are also visible to the code in the ui object. This is because they are loaded into the global environment of the R session; all R code in a Shiny app is run in the global environment or a child of it.
However, this doesn't mean that objects defined in the app.R can't be used on both the UI and Server side, they just belong to a different environment.
For example:
library("shiny")
library("pryr")
# or in global.R
genders <- c("Male", "Female")
gen_env <- where("genders")
par_env <- parent.env(gen_env)
ui <- fluidPage(
selectInput("shiny_gender", "Select Gender", choices = genders),
verbatimTextOutput("selected_gender_index"),
p("The `genders` object belongs to the environment:"),
verbatimTextOutput("gen_env_print"),
p("Which is the child of the environment:"),
verbatimTextOutput("par_env_print")
)
server <- function(input, output) {
output$selected_gender_index <- renderPrint({
# use the 'genders' vector on the server side as well
which(genders %in% input$shiny_gender)
})
output$gen_env_print <- renderPrint(gen_env)
output$par_env_print <- renderPrint(par_env)
}
shinyApp(ui = ui, server = server)
I've looked for get choices of selectinput but without recompute the choices. For example if the datas come from database, or file or other source.
And I didn't get answer. (I get this question but not the solution for me).
Here is ma solution which also could set the selectinput from the server:
set the choices list in a reactive function
build the selectinput in the server side (with the choices list reactive function)
set and get the selectinput in the server side
Here is the code
options(encoding = "UTF-8")
library("shiny")
library("pryr")
ui <- fluidPage(
uiOutput("shiny_gender.UI"),
verbatimTextOutput("selected_gender_index"),
p("The `genders` object belongs to the environment:"),
verbatimTextOutput("gen_env_print"),
p("Which is the child of the environment:"),
verbatimTextOutput("par_env_print"),
p(""),
textInput("set_input_txt","Set the car in letter (for example `Datsun 710`)",
#" Set the Select Input Male / Female ",
""),
actionButton("submit","submit")
)
server <- function(input, output, session) {
observeEvent(
c(input$submit),
{
if (input$submit>0) {
updateSelectInput(session, "shiny_gender",
# server = TRUE, if updateSelectizeInput
choices =shiny_gender.list(),
selected = input$set_input_txt
)
}
}
)
shiny_gender.list <- reactive ({
#c("Male", "Female")
rownames(mtcars)
})
output$shiny_gender.UI <- renderUI({
selectInput( "shiny_gender",
label="Select car",#"Select Gender",
choices =shiny_gender.list()
)
})
output$selected_gender_index <- renderPrint({
which(shiny_gender.list() %in% input$shiny_gender)
})
output$gen_env_print <- renderPrint(where("shiny_gender.list"))
output$par_env_print <- renderPrint(parent.env( where("shiny_gender.list")))
}
shinyApp(ui = ui, server = server)
My shiny app has multiple tabPanels and I want to have a selectizeInput on each of these. However, the input only appears to update on the first panel - ie selectizeInput appears to work only on the first tab. The code below has two identical selectizeInputs which are the updated. Apologies if this is not reproducible elsewhere as it does seem to be odd behavior.
d <- c('t','u','o')
library(shiny)
ui <- fluidPage(
tabsetPanel(
tabPanel('a',uiOutput('a')),
tabPanel('b',uiOutput('b'))
))
server <- function(input, output, session){
output$a <- renderUI({
req(d)
selectizeInput(
'a','test1',choices = NULL,
options = list(placeholder = 'Please select from below'),
multiple = TRUE)
})
observe({
req(d)
updateSelectizeInput(session,
'a',choices = d,
selected = NULL, server = TRUE)
})
output$b <- renderUI({
req(d)
selectizeInput(
'b','test2', choices = NULL,
options = list(placeholder = 'Please select from below'),
multiple = TRUE)
})
observe({
req(d)
updateSelectizeInput(session,
'b',choices = d,selected = NULL,
server = TRUE)
})
}
shinyApp(ui, server)
It is reproducible (thanks!) and the answer is quite simple.
The problem lies in the order your elements are rendered.
(Description might be messy, because you named your elements ambiguously.)
Explanation: Your selected tabPanel is a since it's the first tab available. Your selectizeInput a is therefore rendered. It gets rendered as you specified, with choices = NULL.
Then both observers fire (not because they observe something, but because the server runs through all commands from top to bottom including all observers.)
This leads to selectizeInput a being updated to your choices in d and selectizeInput b is also being updated. Note, that at this point, selectizeInput b wasn't even rendered yet!
So, as you click on tabPanel b, selectizeInput b is rendered for the first time, and as you specified, it is rendered with choices = NULL. Voilà, no choices available.
Solution: You want your observers to observe, so to be run anytime something happens that is important to the observers content. In this case, that is a tabPanel change. In the code below, I added an id to your tabsetPanel and let the observers hear anything that happens with it.
d <- c('t','u','o')
library(shiny)
ui <- fluidPage(
tabsetPanel(id = "x",
tabPanel('a',uiOutput('a')),
tabPanel('b',uiOutput('b'))
))
server <- function(input, output, session){
output$a <- renderUI({
req(d)
selectizeInput(
'a','test1',choices = NULL,
options = list(placeholder = 'Please select from below'),
multiple = TRUE)
})
observe({
req(d)
trigger <- input$x
updateSelectizeInput(session,
'a',choices = d,
selected = NULL, server = TRUE)
})
output$b <- renderUI({
req(d)
selectizeInput(
'b','test2', choices = NULL,
options = list(placeholder = 'Please select from below'),
multiple = TRUE)
})
observe({
req(d)
trigger <- input$x
updateSelectizeInput(session,
'b',choices = d,selected = NULL,
server = TRUE)
})
}
shinyApp(ui, server)
Note: One might even cut one of the observers, and have the remaining one react to the value of input$x.