I have create one app that contains a textInput and a selectizeInput. Depending on the user's input and if the input can be found in one dataset, you will see all the possibilities according to that textInput in the selectizeInput.
In this way, if the user introduces a word that it is not in the dataset, the selectizeInput can't display any choice.
Everything works fine, but I found one problem. If the user starts writing a correct word, the user gets a dropdown list... and then, if the input is removed... the dropdown list is still there (the choices from selectizeInput are still there).
Here the code:
library(shiny)
library(dplyr)
library(stringr)
ui <- fluidPage(
textInput("my_input", "Introduce a word"),
selectizeInput(inputId = "dropdown_list", label = "Choose the variable:", choices=character(0)),
)
server <- function(input, output, session) {
my_list <- reactive({
req(input$my_input)
data <- as.data.frame(storms)
res <- subset(data, (grepl(pattern = str_to_sentence(input$my_input), data$name))) %>%
dplyr::select(name)
res <- as.factor(res$name)
return(res)
})
# This is to generate the choices (gene list) depending on the user's input.
observeEvent(input$my_input, {
updateSelectizeInput(
session = session,
inputId = "dropdown_list",
choices = my_list(), options=list(maxOptions = length(my_list())),
server = TRUE
)
})
}
shinyApp(ui, server)
Do you know how can I remove the choices from the selectizeInput if the user deletes the input?
Thanks very much in advance
Regards
The issue is the req(input$myinput). Hence, if the user deletes the input my_list() does not get updated. Instead of req you could use an if to check whether the input is equal to an empty string:
my_list <- reactive({
if (!input$my_input == "") {
data <- as.data.frame(storms)
res <- subset(data, grepl(pattern = str_to_sentence(input$my_input), data$name), name)
res <- as.factor(res$name)
return(res)
}
})
Related
I used a reactive function on the server to create a data frame.
And I want to express the unique vector of one column of this data frame as selectinput in the UI.
ex)
DATA<-data.frame(ID, NAME)
####server#####
DATAFRAME<-reactive({DATA[DATA$ID %in% input$ID,})
####UI######
selectizeInput("name",label="name:",choices=unique(DATAFRAME$NAME))
In other words, I want to show a list of Names for data that has been refined once by ID in advance.
In order to react to changes in the reactive expression DATAFRAME you can use an observer and update the list of names with updateSelectizeInput (as pointed out by #MrFlick).
library(shiny)
ui <- fluidPage(
titlePanel("Widget Dependencies Sample App"),
selectizeInput("IdSelect", "Choose ID", "N/A"), # IDs to select from
selectizeInput("IdName", "Choose Name", "N/A"), # Names depend on selected ID
tableOutput("IdDatatable") # show the whole data set to understand what happens
)
server <- function(input, output, session) {
ID <- paste("ID", 1:3, sep = "_")
NAME <- LETTERS[1:(3*5)]
DATA <- data.frame(ID, NAME)
updateSelectizeInput(session, "IdSelect", choices = unique(ID))
DATAFRAME <- reactive({DATA[DATA$ID %in% input$IdSelect, ]})
observe({
updateSelectizeInput(session, "IdName", choices = unique(DATAFRAME()$NAME))
})
output$IdDatatable <- renderTable(DATA)
}
shinyApp(ui = ui, server = server)
However, if you need the reactive expression DATAFRAME only once, you can make the code even simpler. In that case, you wouldn't observe a DATAFRAME that reacts to changes in a widget. You can omit the DATAFRAMEand observe the input widget directly. This observer generates a filtered vector of Names and changes the choices in the selectizeInput with only one observer.
observe({
Names <- DATA$NAME[DATA$ID %in% input$IdSelect]
updateSelectizeInput(session, "IdName", choices = unique(Names))
})
I have data that looks something like the data set Orange where there are columns that might contain duplicate values, however, each row is unique.
My code:
library(shiny)
library(DT)
library(data.table)
d <- copy(Orange)
col_names <- names(Orange)
user_friendly_names <- c('TreeNumber', 'TreeAge', 'Circumference')
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
h3("Filters:"),
uiOutput("filters"),
# Plot button
fluidRow(column(2, align = "right",
actionButton("plot_graph_button", "Plot")))
),
mainPanel(tableOutput("summary"))
)
)
server <- function(input, output) {
#### Create the filter lists for UI ####
output$filters <- renderUI({
if(is.null(col_names)) return(NULL)
lapply(1:length(col_names), function(i) {
col <- paste0(col_names[i])
alias <- user_friendly_names[i]
# Populate input with unique values from column
selectizeInput(inputId = alias, label = paste(alias,':'),
choices = c('All', unique(d[[col]])), selected = 'All', multiple = T)
})
})
output$summary <- renderTable({
# Do not show a plot when the page first loads
# Wait until the user clicks "Plot" button
if (input$plot_graph_button == 0){
return()
}
# Update code below everytime the "Plot" button is clicked
input$plot_graph_button
isolate({
# Fresh copy of the full data set every time "Plot" button is clicked
d <- copy(Orange)
# Filter data based on UI
for(f in 1:length(col_names)){
print(paste("This is loop # ", f))
if(eval(parse(text = paste0('is.null(input$',user_friendly_names[f],')')))){
# If the user deleted "All" but failed to pick anything else default to "All" - do not filter
break
}else{
if(eval(parse(text = paste0('input$',user_friendly_names[f]))) != "All"){
print("FALSE -- Input is not == ALL")
d <- d[d[[col_names[f]]] == unlist(eval(parse(text = paste0('input$',user_friendly_names[f])))), ]
}else{
print("TRUE -- Input is defaulted to ALL")
}
}
}
final_summary_table <<- d
})
})
}
shinyApp(ui = ui, server = server)
My issue is that these lists are able to select multiple inputs (which I want), however, I want to initially show all available choices in all menus (which it currently does) but what I need to change is I need to have it start filtering the other lists as soon as a selection is made (no matter which list the user goes to first) based on that unique rowed data set provided.
So, if the user goes to the 2nd list and chooses tree age of 1004 then the TreeNumber menu should change to c(1, 2, 3, 4, 5) - no change in this scenario but the Circumference menu should change to c(115, 156, 108, 167, 125), then if they pick a TreeAge now the menus get filtered down by both TreeAge and TreeNumber and so on.
Right now the way the code works is it doesn't filter anything until you click "Plot", so the user might think a search will yield a bunch of results, when in reality the combination may not exist.
Here is a good example of a search that you may expect to yield a lot of results, yet it only yields 1 row:
Please note: If you do not delete 'All' it will return 'All' even if you selected other options, it is a flaw in the code that I plan to address separately along with some other minor tweaks.
I also wanted to mention that I found this post Filter one selectInput based on selection from another selectInput? which is similar to mine, however, they are dealing with menus in a top-down approach and mine is going to be more flexible about which menu the user goes to first (also mine allows multiple selections).
server <- function(input, output, session) {
output$filters <- renderUI({
# ...
})
lapply(seq_along(d), function(i) {
observeEvent(input[[user_friendly_names[i]]], {
for (j in seq_along(d)[-i]) {
choices <- if ("All" %in% input[[user_friendly_names[i]]])
unique(d[[j]]) else
unique(d[[j]][d[[i]] %in% input[[user_friendly_names[i]]]])
choices <- c("All", choices)
selected <- intersect(choices, input[[user_friendly_names[j]]])
updateSelectInput(session = session, inputId = user_friendly_names[j],
choices = choices, selected = selected)
}
})
})
observeEvent(input$plot_graph_button, {
for (j in seq_along(d)) {
updateSelectInput(session = session, inputId = user_friendly_names[j],
choices = c("All", unique(d[[j]])), selected = "All")
}
})
output$summary <- renderTable({
# ...
})
}
A common scenario for many of my shiny apps is that there is a large list of potentially interesting filter variables (often 10 to 20), but I want to avoid confusing the user with too many input widgets.
Therefore, my strategy is usually as follows:
1. Users may select filter variables. 2. If at least one filter variable is selected, a renderUI is triggered, which contains one input widget per selected variable. 3. The filter criteria are applied to the data and some output is generated.
The problem is that any change in step one (by adding or deleting a filter variable) eliminates all previously made choices from step two. This means that all input widgets are unintentionally reset to their default values. This prevents a smooth user experience. Any idea how to improve on this?
Here you can see what happens:
And here is the code to reproduce this behaviour:
library("shiny")
library("dplyr")
library("nycflights13")
df <- flights
filtervarsChoices <- c("origin","carrier")
originChoices <- unique(df$origin)
carrierChoices <- unique(df$carrier)
ui <- fluidPage(
h3("1. Select Filter variables"),
selectInput("filterVars", "Filter variables", filtervarsChoices, multiple = TRUE),
uiOutput("filterConditions"),
h3("Result"),
tableOutput("average")
)
server <- function(input, output, session) {
output$filterConditions <- renderUI({
req(input$filterVars)
tagList(
h3("2. Select Filter values"),
if ("origin" %in% input$filterVars) {
selectInput("originFilter", "Origin", originChoices, multiple = TRUE)
},
if ("carrier" %in% input$filterVars) {
selectInput("carrierFilter", "Carrier", carrierChoices, multiple = TRUE)
}
)
})
output$average <- renderTable({
if ("origin" %in% input$filterVars) {
df <- df %>% filter(origin %in% input$originFilter)
}
if ("carrier" %in% input$filterVars) {
df <- df %>% filter(carrier %in% input$carrierFilter)
}
df %>%
summarise(
"Number of flights" = n(),
"Average delay" = mean(arr_delay, na.rm = TRUE)
)
})
}
shinyApp(ui = ui, server = server)
The problem is that you render the UI element every time it is selected, and thus its selected choices are reset. We can solve this by only rendering the elements a single time, and showing or hiding them when applicable. We can do this with the show and hide functions from the shinyjs package, and by wrapping div's around the selectInputs as we create them. So each filter x gets a corresponding input called xFilter and a div wrapped around it called div_x.
Below is a working example. I have tried to make the code as general as possible, so that you would only have to supply additional elements in filtervarsChoices and in choices_list to extend with additional filters. I also modified the table that is outputted to show that the filters are working correctly.
Note that in the example below, hidden filters are still applied to the resulting data.frame. In order to only apply visible filters, the for loop should run over input$filterVars as shown by Till n the comments below.
I hope this helps!
library("shiny")
library("dplyr")
library("nycflights13")
library(shinyjs)
df <- flights
filtervarsChoices <- c("origin","carrier")
originChoices <- unique(df$origin)
carrierChoices <- unique(df$carrier)
# Create a list with the choices for the selectInputs.
# So the selectInput for 'origin', will get the choices defined in originChoices.
choices_list <- list('origin' = originChoices,
'carrier' = carrierChoices)
ui <- fluidPage(
column(width=3,
h3("1. Select Filter variables"),
selectInput("filterVars", "Filter variables", filtervarsChoices, multiple = TRUE),
uiOutput("filterConditions"),
h3("Result"),
tableOutput("average"),
useShinyjs()
),
column(width=3,
h3("Applied filters"),
htmlOutput('appliedfilters')
)
)
server <- function(input, output, session) {
# Render all selectInput elements.
output$filterConditions <- renderUI({
lapply(filtervarsChoices, function(x){
shinyjs::hidden(div(id=paste0('div_',x),
selectInput(paste0(x,"Filter"), x, choices_list[[x]], multiple = TRUE)
))})
})
# Show all divs that are selected, hide all divs that are not selected.
observeEvent(input$filterVars, ignoreNULL = F,
{
to_hide = setdiff(filtervarsChoices,input$filterVars)
for(x in to_hide)
{
shinyjs::hide(paste0('div_',x))
}
to_show = input$filterVars
for(x in to_show)
{
shinyjs::show(paste0('div_',x))
}
})
output$appliedfilters <- renderText({
applied_filters <- c()
for(x in filtervarsChoices) # for(x in input$filterVars)
{
if(!is.null(input[[paste0(x,'Filter')]]))
{
applied_filters[length(applied_filters)+1] = paste0(x,': ', paste(input[[paste0(x,'Filter')]],collapse=", "))
}
}
paste(applied_filters,collapse='<br>')
})
output$average <- renderTable({
# For all variables, filter if the input is not NULL.
# In the current implementation, all filters are applied, even if they are hidden again by the user.
# To make sure only visible filters are applied, make the loop run over input$filterVars instead of filterVarsChoices
for(x in filtervarsChoices) # for(x in input$filterVars)
{
if(!is.null(input[[paste0(x,'Filter')]]))
{
df <- df %>% filter(get(x) %in% input[[paste0(x,'Filter')]])
}
}
unique(df[,c('origin','carrier')])
})
}
shinyApp(ui = ui, server = server)
To filter a data.frame with lots of variables I created a selectizeInput which allows you to select one of the columns of the data. This then creates another selectizeInput for the selected variable which can be used for subsetting the data. The selected value of the second selectizeInput is rendered below.
This is what it looks like
I want to render the selected values of these inputs so that these can be deleted by the user by clicking the black cross. Also a selection of var2 should not be deleted when the Filter selectizeInput is changed to var1.
So it should look like this (assuming the user previously selected value z in var2 and then value a in var1.
Anyone knows a good solution in shiny?
This is the code:
library(shiny)
data <- data.frame(var1 = c("a", "b"), var2 = c("y", "z"))
ui <- fluidPage(
selectizeInput("filter", label = "Filter",
multiple = FALSE, choices = c("var1", "var2")),
uiOutput("filter_var"),
uiOutput("selected_filter_value")
)
server <- function(input, output) {
observeEvent(input$filter, {
# dynamically generate selectizeInput for filter
output$filter_var <- renderUI({
selectizeInput(input$filter, label = input$filter,
choices = data[input$filter], multiple = TRUE)
})
})
# show selected filter values
# selected filter values should stay when choosing new input filter variable
# these should be deletable
observeEvent(input[[input$filter]], {
output$selected_filter_value <- renderUI({
textOutput("text_out")
})
output$text_out <- renderText({
paste0(input$filter, ": ", input[[input$filter]])
})
})
}
shinyApp(ui, server)
Well, I had to rearrange quite a lot and this whole problem is more about finding the right implementation for your case.
You can probably deduct most of it just looking at the code at the end of this post.
Main things explained: You didn't actually say what deleting means to you. So I just assumed you wanted the cells to not appear in the select boxes anymore. For that, I excluded NAs and replaced cells with an NA to show that they are deleted.
I rearranged the select values, such that we actually can delete certain cells, giving row and column names instead of just their values.
And most important, the buttons you wanted to create are dynamic UI elements with dynamic observers, which are then addressed to delete the certain cell.
Note: This solution is not optimal, since I specifically aimed to stay just on the R side of shiny. You can achieve a much more elegant and resource saving solution if you use JavaScript and shiny's custom messages.
Also: I did not address your request to let the selected values visible if the first select box changes. But this is a rather small issue, if you reconsider your setup. And I didn't want to diverge too much from you original code to not be confusing.
Code now:
library(shiny)
data <- data.frame(var1 = c("a", "b"), var2 = c("y", "z"))
ui <- fluidPage(
selectizeInput("filter", label = "Filter",
multiple = FALSE, choices = c("var1", "var2")),
uiOutput("filter_var"),
uiOutput("selected_filter_value")
)
server <- function(input, output) {
# Pulled out from original observeEvent
makeSecondInput <- function() {
output$filter_var <- renderUI({
# Names are not enough when wanting to delete data.frame rows (because of duplicates).
# So we instead use row numbers and set the actual values as labels.
choiceData <- na.exclude(data[input$filter])
choices <- rownames(choiceData)
names(choices) <- choiceData[, input$filter]
selectizeInput(input$filter, label = input$filter, selected = input[[input$filter]],
choices = choices, multiple = TRUE)
})
}
observeEvent(input$filter, {
makeSecondInput()
})
# Install a manual trigger to redraw input field, when an option is killed.
trigger <- reactiveVal()
observeEvent(trigger(), ignoreNULL = TRUE, {
makeSecondInput()
})
# Keep track of created observers, so dynamic creation does not wildly stack them up.
observersCreated <- character()
makeButtonObserver <- function(buttonname, colname, rowname) {
# For each delete-button created, install observer to delete data.frame cell.
observeEvent(input[[buttonname]], {
data[rowname, colname] <<- NA
# Force re-evaluation of observer above.
trigger(runif(1))
})
# Track that this button is equipped. (And re-creation of the same button does not add another obs.)
# Note: Observers DON'T get automagically removed after actionButton is no longer in the UI.
observersCreated <<- c(observersCreated, buttonname)
}
observeEvent(input[[input$filter]], {
output$selected_filter_value <- renderUI({
# Could be a list, so splitting that up.
lapply(input[[input$filter]], function(v) {
buttonname <- paste("kill", input$filter, v, sep = "_")
if (!(buttonname %in% observersCreated)) {
makeButtonObserver(buttonname, input$filter, v)
}
span(
paste0(input$filter, ": ", data[v, input$filter]),
actionButton(buttonname, "x")
)
})
})
})
}
shinyApp(ui, server)
This is what I currently have. There are still some issues which I couldn't solve.
Problems:
if I make some selections in input1, then switch from input1 to input2 and unclick one of the selections from input1 and then switch back to input1 these changes will be unmade
the checkboxes are rerendered when a new one is added and in this process sorted which changes the order
Code:
library(shiny)
library(shinyWidgets)
data <- data.frame(var1 = c("a", "b"), var2 = c("y", "z"))
ui <- fluidPage(
selectizeInput("filter", label = "Filter",
multiple = FALSE, choices = c("var1", "var2")),
uiOutput("filter_var"),
uiOutput("selected_filter_value")
)
server <- function(input, output, session) {
values <- reactiveValues(
filter_vals = list(var1 = list(), var2 = list()),
observers = NULL
)
# dynamically generate selectizeInput for variable selected in filter
# set selected values to previous selections
observeEvent(input$filter, {
output$filter_var <- renderUI({
selectInput(input$filter, label = input$filter,
selected = values$filter_vals[[input$filter]],
choices = data[input$filter], multiple = TRUE, selectize = TRUE)
})
})
# store selected values in list
observeEvent(input[[input$filter]], {
values$filter_vals[[input$filter]] <- input[[input$filter]]
})
# we need this because observeEvent is not triggered if input is empty after deleting all selections
observe({
if (is.null(input[[input$filter]])) {
values$filter_vals[[input$filter]] <- list()
}
})
# add an observer for newly created checkbox
# if checkbox is clicked delete entry in list
# keep a list of all existing observers
make_delete_observer <- function(name) {
observeEvent(input[[name]], {
req(input[[name]] == FALSE)
var <- stringr::str_split(name, "_")[[1]][1]
val <- as.integer(stringr::str_split(name, "_")[[1]][2])
values$filter_vals[[var]] <- intersect(values$filter_vals[[var]][-val],
values$filter_vals[[var]])
updateSelectInput(session, var, selected = values$filter_vals[[var]])
})
}
# render selected values which are stored in a list as checkboxes
# add an observeEvent for each checkbox
# store selected values in list
output$selected_filter_value <- renderUI({
req(values$filter_vals[[input$filter]])
req(any(sapply(values$filter_vals, length) > 0))
tag_list <- tagList()
for (i in seq_along(values$filter_vals)) {
for (j in seq_along(values$filter_vals[[i]])) {
new_input_name <- paste0(names(values$filter_vals)[i], "_", j)
new_input <- prettyCheckbox(
inputId = new_input_name, value = TRUE,
label = paste0(names(values$filter_vals)[i], ": ", values$filter_vals[[i]][j]),
icon = icon("close"), status = "danger", outline = FALSE, plain = TRUE
)
# create observer only if it does not exist yet
if (!(new_input_name %in% values$observers)) {
values$observers <- append(values$observers, new_input_name)
make_delete_observer(new_input_name)
}
tag_list <- tagAppendChild(tag_list, new_input)
}
}
tag_list
})
}
shinyApp(ui, server)
Typically in a web interface if you have a dropdown populated from a database that display's some text and you want to use that selected text in the dropdown and pass it back to a database. But a lot of times you want to pass an ID instead of the actual text displayed.
In my example below I have a global.R file that returns the data for the dropdowns. This simulates data returned from a database. For each dropdown there is a text field that is displayed in the dropdowns and an "id" field that is not displayed BUT I have to somehow access the "id" fields of the dropdowns. How is this done in Shiny?... Because the selectInputs don't allow you to store the ids so you can access them like input$DisplayName$id
In the example below I just want to print the "id" of the "DisplayName" selectInput so if "Mary" is in the input$DisplayName then "20" should be printed in the RenderText call.
Here is code to run:
require(shiny)
runApp(list(
ui = basicPage(
sidebarPanel(
selectInput("Department", "Select a department", choices = as.character(GetDepartments()$Department), selected = as.character(GetDepartments()$Department[1])),
uiOutput("DisplayName")
),
mainPanel(textOutput("Text") )
),
server = function(input, output, session) {
output$DisplayName<-renderUI({
Department <- input$Department
print(Department)
selectInput("DisplayName", 'DisplayName:', choices = as.character(GetDisplayName(Department)$DisplayName), selected =as.character(GetDisplayName(Department)$DisplayName[1] ))
})
output$Text <- renderText({
# Here I want to simulate accessing the "id" field of the input$DisplayName
#in my app I need to pass the id to a database query
#If Mary is in input$DisplayName how can I access her id of "20"?
print("in render text")
return( ??? How do I access the id = 20???)
})
}
))
Here is the global.r file that simulates code that returns stuff from a database
GetDepartments<- function(){
df<- data.frame(Department= c("Dept A", "Dept B"), id = c(1,2))
return(df)
}
GetDisplayName<- function(Dept){
if(Dept == "Dept A")
{
df<- data.frame(DisplayName= c("Bob", "Fred"), id = c(4,6))
return(df)
}else
{
df<- data.frame(DisplayName= c("George", "Mary"), id = c(10,20))
return(df)
}
}
This is very similar to your other question here. As #nrussel suggests, this is just a simple subsetting problem. Just pull up your department and index on the name. Here is a working example.
EDIT*** - make dataset reactive to avoid repetition.
As per the documentation:
Reactive expressions are a smarter than regular R functions. They cache results and only update when they become obsolete. The first time that you run a reactive expression, the expression will save its result in your computer’s memory. The next time you call the reactive expression, it can return this saved result without doing any computation (which will make your app faster). The reactive expression will use this new copy until it too becomes out of date.
runApp(list(
ui = basicPage(
sidebarPanel(
selectInput("Department", "Select a department",
choices = as.character(GetDepartments()$Department),
selected = as.character(GetDepartments()$Department[1])),
uiOutput("DisplayName")
),
mainPanel(textOutput("Text") )
),
server = function(input, output, session) {
myData <- reactive({
GetDisplayName(input$Department)
})
output$DisplayName<-renderUI({
Department <- input$Department
print(Department)
myData <- myData()
selectInput("DisplayName", 'DisplayName:', choices = as.character(myData$DisplayName),
selected =as.character(myData$DisplayName[1] ))
})
output$Text <- renderText({
print("in render text")
myData <- myData()
code <- as.character(myData[myData$DisplayName == input$DisplayName,2])
return(code)
})
}
))