My goal is to implement a Shiny app which shows several "problems" to the user with a list of possible answers, then lets the user choose an answer and stores it. Every problem has a previously stored answer that the user can overwrite.
I can't find a way to satisfy these two constraints at the same time with reactive objects:
let the user select the next problem, with the answer being re-initialized from the previously stored answer
store the answer for the current problem when the user selects a new answer (and only in this case)
Below a simplified code (no data, no loading/writing) which shows my current attempt. In this version the issue is that when a new problem is selected, the selected answer from the previous problem is immediately written.
library(shiny)
maxProblem=10
ui <- fluidPage(
titlePanel("Debugging test"),
fluidRow(
column(12,
verbatimTextOutput("nbProblems"),
uiOutput("ProblemSelection"),
uiOutput("answerSelection")
)
)
)
server <- function(input, output) {
output$ProblemSelection <- renderUI({
numericInput("ProblemSelectionNo",
"Select Problem no",
value = 1, min=1, max=maxProblem)
})
currentProblemData <- reactive({
print("calling loadCurrentProblemData")
if (!is.null(input$ProblemSelectionNo)) {
print("pretending to load data and previously stored answer for problem", input$ProblemSelectionNo)
list( choices=c(1,2,3), answer=1)
}
})
output$answerSelection <- renderUI({
l<-currentProblemData()
choicesList <- l$choices
names(choicesList) <- l$choices
radioButtons("answerInput", label = "Select answer",
choices = choicesList,
selected = l$answer)
})
writeChanges <- observe({
print('calling writeChanges')
l<-currentProblemData()
newAnswer <- input$answerInput
prevAnswer <- l$answer
if (!is.null(prevAnswer) && !is.null(newAnswer) && (newAnswer != prevAnswer)) {
print(paste('Pretending to write new answer :',newAnswer,'for problem', input$ProblemSelectionNo))
l$answer <- newAnswer
}
})
}
# Run the application
shinyApp(ui = ui, server = server)
This might have the functionality you are looking for. I made a workable example to try based on some of what you have.
First, I created a default list choices_answer which could flexibly store your default problem choices and answers. A reactiveValues list lst (rv$lst) will start with this, and then change as new answers are selected to store the new responses.
When a new problem is selected through the numericInput, then the radioButtons are updated based on the current answer for that problem (using the rv$lst). Likewise, when a new answer is chosen (or answer is changed), the rv$lst will be updated with the new answer for storage.
I also added output ListData to show what the storage of answers looks like as you make selections using the radio buttons.
library(shiny)
maxProblem = 5
choices_answer = list()
for (i in seq_along(1:maxProblem)) {
choices_answer[[i]] <- list(
choices = c("1", "2", "3"),
answer = "1"
)
}
ui <- fluidPage(
titlePanel("Debugging test"),
fluidRow(
column(12,
numericInput("ProblemSelectionNo",
"Select Problem no",
value = 1, min = 1, max = maxProblem),
radioButtons("answerInput", label = "Select answer",
choices = choices_answer[[1]][["choices"]]),
verbatimTextOutput("ListData")
)
)
)
server <- function(input, output, session) {
rv <- reactiveValues(lst = choices_answer)
observeEvent(input$ProblemSelectionNo, {
updateRadioButtons(session, "answerInput",
choices = rv$lst[[input$ProblemSelectionNo]][["choices"]],
selected = rv$lst[[input$ProblemSelectionNo]][["answer"]])
})
observeEvent(input$answerInput, {
rv$lst[[input$ProblemSelectionNo]][["answer"]] <- input$answerInput
})
output$ListData <- renderPrint({rv$lst})
}
# Run the application
shinyApp(ui = ui, server = server)
I would like to provide reactively drop down choices (autocomplete suggestions) to the user depending on the input he provides. User input and autocomplete suggestions should be in the same widget.
The problem is, that I have a large data set (1 million rows+) from which the user should be able to choose names from. Since preloading this large data set would slow down the app, I would like to work with multiple splitted data sets, which I load depending on first letter of the user input.
The goal is to provide something like a textInput widget where the user is able to start typing a name. Depending on the first letter of this user input, I would like to present suggestions to the user from which he should be able to choose from.
Unfortunately this is not possible with:
textInput (lacks of drop down with suggestions)
selectInput / selectizeInput / select2Input (lacks of ability to work with non-pre loaded data)
Here are my failed trails with different input widgets to get this to work.
library(shiny)
library(shinysky)
#ui
ui <- fluidPage(
#Text Input
textInput(inputId = "txtInput", label = "Text Input", value = NULL),
#Select Input
selectInput(inputId = "selectInput", label = "Select Input", choices = NULL),
#Selectize Input
selectizeInput(inputId = "selectizeInput", label = "Selectize Input", choices = NULL),
#Select2Input from shinysky
select2Input(inputId = "select2Input", label = "Select2 Input", choices = NULL)
)
#server
server <- function(input, output, session) {
#Create reactive values
rv <- reactiveValues()
#Function for loading specific data set
f.populate.values <- function(start.letter) {
data.set <- c()
if(start.letter == "a") {
#Example toy list
data.set <- c("aaa", "abc", "adb", "adf")
}
if(start.letter == "b") {
#Example toy list
data.set <- c("baa", "bbc", "bdb", "bdf")
}
return(data.set)
}
#Failed trials to update / generate a dropdown with the loaded data set from "f.populate.values"
observeEvent(input$txtInput, {
#Store loaded data depending on first typed character
rv$names <- f.populate.values(substring(input$txtInput, 1, 1))
#Trials to update suggestions in widgets
updateTextInput(inputId = "txtInput", value = rv$names, session = session)
updateSelectInput(inputId = "selectInput", choices = rv$names, session = session)
updateSelectizeInput(inputId = "selectizeInput", choices = rv$names, session = session)
updateSelect2Input(inputId = "select2Input", choices = rv$names, label = "Select 2 Input", session = session)
})
}
shinyApp(ui, server)
I am making something i Shiny and am wondering whether it is possible to make radiobuttons decide another input.
A toy example that replicates my problem is given by:
if (interactive()) {
ui <- fluidPage(
radioButtons("dist", "Distribution type:",
c("Normal" = "norm",
"Uniform" = "unif")),
textInput(inputId = "textid", label = "Text input-header", value = "rnorm"),
plotOutput("distPlot")
)
server <- function(input, output) {
df <- reactive({
switch(input$textid,
rnorm = {rnorm(500)},
uni = {runif(500)},
exp = {rexp(500)},
)})
output$distPlot <- renderPlot(hist(df())
)
}
shinyApp(ui, server)
}
As it is now, it is the input in the text box that decides what kind of distribution, that is used to generate the data. What I would like is that when one clicks of one of the radio buttons then the text is updated in the text box (e.g. if "Uniform" is checked off, then the textunput is updated with "uni" - and thereby this distribution is used). The thing is that I need the box since I would like to be able to choose somethiong that is not an option among the radio buttons (so it does not work for me just to add extra radio buttons). The extra option in this case is, that one can write "exp" in the text input (this distribution cannot be chosen from a radio button).
It might seem a bit idiotic in this example, but in my case I have 2 very often used timestamps, but the app must allow the user to choose every possible date as well.
Is this somehow possible?
Thanks in advance!
Something like this? Note that I added the req where it is required to have your text input as one of "rnorm","uni","exp"
library(shiny)
if (interactive()) {
ui <- fluidPage(
radioButtons("dist", "Distribution type:",c("Normal" = "rnorm","Uniform" = "uni","Exponential" = "exp")),
textInput(inputId = "textid", label = "Text input-header", value = "rnorm"),
plotOutput("distPlot")
)
server <- function(input, output,session) {
observeEvent(input$dist,{
updateTextInput(session, "textid",label = "Text input-header",value = input$dist)
})
df <- eventReactive(input$textid,{
req(input$textid %in%c("rnorm","uni","exp"))
switch(input$textid, rnorm = {rnorm(500)},uni = {runif(500)}, exp = {rexp(500)},
)})
output$distPlot <- renderPlot(hist(df()))
}
shinyApp(ui, server)
}
I am trying to dynamically populate the values of the selectInput from the data file uploaded by the user. The selectInput must contain only numeric columns.
Here is my code snippet for server.R
...
idx <- sapply(data.file, is.numeric)
numeric_columns <- data.file[, idx]
factor_columns <- data.file[, !idx]
updateSelectInput(session, "bar_x", "Select1", choices = names(numeric_columns))
updateSelectInput(session, "bar_y", "Select2", choices = names(factor_columns))
...
Corresponding ui.r
...
selectInput("bar_x", "Select1", choices = NULL),
selectInput("bar_y", "Select2", choices = NULL)
...
The code works fine as long as there are more than one values in any dropdown. However, it fails as soon as it encounters only one value to be displayed in the selectInput.
How can I handle this specific condition, given that the data is uploaded and it cannot be controlled if there is just one column as numeric?
It appears that in 2019, this issue still exists. The issue that I have seen is that when there is only one option in the dropdown, the name of the column is displayed instead of the one option.
This appears to only be a graphical problem, as querying the value for the selectInput element returns the correct underlying data.
I was unable to figure out why this problem exists, but an easy way around this bug is to simply change the name of the column so that it looks like the first element in the list.
library(shiny)
ui <- fluidPage(
selectInput("siExample",
label = "Example Choices",
choices = list("Loading...")),
)
server <- function(input, output, session) {
# load some choices into a single column data frame
sampleSet <- data.frame(Example = c("test value"))
# rename the set if there is only one value
if (length(sampleSet$Example) == 1) {
# This should only be done on a copy of your original data,
# you don't want to accidentally mutate your original data set
names(sampleSet) <- c(sampleSet$Example[1])
}
# populate the dropdown with the sampleSet
updateSelectInput(session,
"siExample",
choices = sampleSet)
}
shinyApp(ui = ui, server = server)
Info: Code was adapted by OP to make error reproducible.
To solve your issue use val2 <- val[,idx, drop = FALSE]
You dropped the column names by subsetting the data.frame().
To avoid this use drop = FALSE; see Keep column name when select one column from a data frame/matrix in R.
library(shiny)
# Define UI for application that draws a histogram
ui <- fluidPage(
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
# drj's changes START block 1
#selectInput('states', 'Select states', choices = c(1,2,4))
selectInput('states', 'Select states', choices = NULL)
# drj's changes END block 1
),
# Show a plot of the generated distribution
mainPanel(
plotOutput("distPlot")
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output, session) {
observe({
#drj's changes START block 2
#val <- c(1,2,3)
#names(val) <- c("a","b","c")
#updateSelectInput(session, 'states', 'Select states', choices = names(val[1]))
val <- as.data.frame(cbind(c("_1","_2","_3"), c(4, 4, 6)))
names(val) <- c("a","b")
val$b <- as.numeric(val$b)
idx <- sapply(val, is.numeric)
val2 <- val[,idx, drop = FALSE]
updateSelectInput(session, 'states', 'Select states', choices = names(val2))
#drj's changes END block 2
})
}
# Run the application
shinyApp(ui = ui, server = server)
The goal
I am working on a Shiny app that allows the user to upload their own data and focus on the entire data or a subset by providing data filtering widgets described by the below graph
The select input "Variable 1" will display all the column names of the data uploaded by the user and the selectize input "Value" will display all the unique values of the corresponding column selected in "Variable 1". Ideally, the user will be able to add as many such rows ("Variable X" + "Value") as possible by some sort of trigger, one possibility being clicking the "Add more" action button.
A possible solution
After looking up online, I've found one promising solution given by Nick Carchedi pasted below
ui.R
library(shiny)
shinyUI(pageWithSidebar(
# Application title
headerPanel("Dynamically append arbitrary number of inputs"),
# Sidebar with a slider input for number of bins
sidebarPanel(
uiOutput("allInputs"),
actionButton("appendInput", "Append Input")
),
# Show a plot of the generated distribution
mainPanel(
p("The crux of the problem is to dynamically add an arbitrary number of inputs
without resetting the values of existing inputs each time a new input is added.
For example, add a new input, set the new input's value to Option 2, then add
another input. Note that the value of the first input resets to Option 1."),
p("I suppose one hack would be to store the values of all existing inputs prior
to adding a new input. Then,", code("updateSelectInput()"), "could be used to
return inputs to their previously set values, but I'm wondering if there is a
more efficient method of doing this.")
)
))
server.R
library(shiny)
shinyServer(function(input, output) {
# Initialize list of inputs
inputTagList <- tagList()
output$allInputs <- renderUI({
# Get value of button, which represents number of times pressed
# (i.e. number of inputs added)
i <- input$appendInput
# Return if button not pressed yet
if(is.null(i) || i < 1) return()
# Define unique input id and label
newInputId <- paste0("input", i)
newInputLabel <- paste("Input", i)
# Define new input
newInput <- selectInput(newInputId, newInputLabel,
c("Option 1", "Option 2", "Option 3"))
# Append new input to list of existing inputs
inputTagList <<- tagAppendChild(inputTagList, newInput)
# Return updated list of inputs
inputTagList
})
})
The downside
As pointed by Nick Carchedi himself, all the existing input widgets will undesirably get reset every time when a new one is added.
A promising solution for data subsetting/filtering in Shiny
As suggested by warmoverflow, the datatable function in DT package provides a nice way to filter the data in Shiny. See below a minimal example with data filtering enabled.
library(shiny)
shinyApp(
ui = fluidPage(DT::dataTableOutput('tbl')),
server = function(input, output) {
output$tbl = DT::renderDataTable(
iris, filter = 'top', options = list(autoWidth = TRUE)
)
}
)
If you are going to use it in your Shiny app, there are some important aspects that are worth noting.
Filtering box type
For numeric/date/time columns: range sliders are used to filter rows within ranges
For factor columns: selectize inputs are used to display all possible categories
For character columns: ordinary search boxes are used
How to obtain the filtered data
Suppose the table output id is tableId, use input$tableId_rows_all as the indices of rows on all pages (after the table is filtered by the search strings). Please note that input$tableId_rows_all returns the indices of rows on all pages for DT (>= 0.1.26). If you use the DT version by regular install.packages('DT'), only the indices of the current page are returned
To install DT (>= 0.1.26), refer to its GitHub page
Column width
If the data have many columns, column width and filter box width will be narrow, which makes it hard to see the text as report here
Still to be solved
Despite some known issues, datatable in DT package stands as a promising solution for data subsetting in Shiny. The question itself, i.e. how to dynamically append arbitrary number of input widgets in Shiny, nevertheless, is interesting and also challenging. Until people find a good way to solve it, I will leave this question open :)
Thank you!
are you looking for something like this?
library(shiny)
LHSchoices <- c("X1", "X2", "X3", "X4")
#------------------------------------------------------------------------------#
# MODULE UI ----
variablesUI <- function(id, number) {
ns <- NS(id)
tagList(
fluidRow(
column(6,
selectInput(ns("variable"),
paste0("Select Variable ", number),
choices = c("Choose" = "", LHSchoices)
)
),
column(6,
numericInput(ns("value.variable"),
label = paste0("Value ", number),
value = 0, min = 0
)
)
)
)
}
#------------------------------------------------------------------------------#
# MODULE SERVER ----
variables <- function(input, output, session, variable.number){
reactive({
req(input$variable, input$value.variable)
# Create Pair: variable and its value
df <- data.frame(
"variable.number" = variable.number,
"variable" = input$variable,
"value" = input$value.variable,
stringsAsFactors = FALSE
)
return(df)
})
}
#------------------------------------------------------------------------------#
# Shiny UI ----
ui <- fixedPage(
verbatimTextOutput("test1"),
tableOutput("test2"),
variablesUI("var1", 1),
h5(""),
actionButton("insertBtn", "Add another line")
)
# Shiny Server ----
server <- function(input, output) {
add.variable <- reactiveValues()
add.variable$df <- data.frame("variable.number" = numeric(0),
"variable" = character(0),
"value" = numeric(0),
stringsAsFactors = FALSE)
var1 <- callModule(variables, paste0("var", 1), 1)
observe(add.variable$df[1, ] <- var1())
observeEvent(input$insertBtn, {
btn <- sum(input$insertBtn, 1)
insertUI(
selector = "h5",
where = "beforeEnd",
ui = tagList(
variablesUI(paste0("var", btn), btn)
)
)
newline <- callModule(variables, paste0("var", btn), btn)
observeEvent(newline(), {
add.variable$df[btn, ] <- newline()
})
})
output$test1 <- renderPrint({
print(add.variable$df)
})
output$test2 <- renderTable({
add.variable$df
})
}
#------------------------------------------------------------------------------#
shinyApp(ui, server)
Now, I think that I understand better the problem.
Suppose the user selects the datasets::airquality dataset (here, I'm showing only the first 10 rows):
The field 'Select Variable 1' shows all the possible variables based on the column names of said dataset:
Then, the user selects the condition and the value to filter the dataset by:
Then, we want to add a second filter (still maintaining the first one):
Finally, we get the dataset filtered by the two conditions:
If we want to add a third filter:
You can keep adding filters until you run out of data.
You can also change the conditions to accommodate factors or character variables. All you need to do is change the selectInput and numericInput to whatever you want.
If this is what you want, I've solved it using modules and by creating a reactiveValue (tmpFilters) that contains all selections (variable + condition + value). From it, I created a list with all filters (tmpList) and from it I created the proper filter (tmpListFilters) to use with subset.
This works because the final dataset is "constantly" being subset by this reactiveValue (the tmpFilters). At the beginning, tmpFilters is empty, so we get the original dataset. Whenever the user adds the first filter (and other filters after that), this reactiveValue gets updated and so does the dataset.
Here's the code for it:
library(shiny)
# > MODULE #####################################################################
## |__ MODULE UI ===============================================================
variablesUI <- function(id, number, LHSchoices) {
ns <- NS(id)
tagList(
fluidRow(
column(
width = 4,
selectInput(
inputId = ns("variable"),
label = paste0("Select Variable ", number),
choices = c("Choose" = "", LHSchoices)
)
),
column(
width = 4,
selectInput(
inputId = ns("condition"),
label = paste0("Select condition ", number),
choices = c("Choose" = "", c("==", "!=", ">", ">=", "<", "<="))
)
),
column(
width = 4,
numericInput(
inputId = ns("value.variable"),
label = paste0("Value ", number),
value = NA,
min = 0
)
)
)
)
}
## |__ MODULE SERVER ===========================================================
filter <- function(input, output, session){
reactive({
req(input$variable, input$condition, input$value.variable)
fullFilter <- paste0(
input$variable,
input$condition,
input$value.variable
)
return(fullFilter)
})
}
# Shiny ########################################################################
## |__ UI ======================================================================
ui <- fixedPage(
fixedRow(
column(
width = 5,
selectInput(
inputId = "userDataset",
label = paste0("Select dataset"),
choices = c("Choose" = "", ls("package:datasets"))
),
h5(""),
actionButton("insertBtn", "Add another filter")
),
column(
width = 7,
tableOutput("finalTable")
)
)
)
## |__ Server ==================================================================
server <- function(input, output) {
### \__ Get dataset from user selection ------------------------------------
originalDF <- reactive({
req(input$userDataset)
tmpData <- eval(parse(text = paste0("datasets::", input$userDataset)))
if (!class(tmpData) == "data.frame") {
stop("Please select a dataset of class data.frame")
}
tmpData
})
### \__ Get the column names -----------------------------------------------
columnNames <- reactive({
req(input$userDataset)
tmpData <- eval(parse(text = paste0("datasets::", input$userDataset)))
names(tmpData)
})
### \__ Create Reactive Filter ---------------------------------------------
tmpFilters <- reactiveValues()
### \__ First UI Element ---------------------------------------------------
### Add first UI element with column names
observeEvent(input$userDataset, {
insertUI(
selector = "h5",
where = "beforeEnd",
ui = tagList(variablesUI(paste0("var", 1), 1, columnNames()))
)
})
### Update Reactive Filter with first filter
filter01 <- callModule(filter, paste0("var", 1))
observe(tmpFilters[['1']] <- filter01())
### \__ Other UI Elements --------------------------------------------------
### Add other UI elements with column names and update the filter
observeEvent(input$insertBtn, {
btn <- sum(input$insertBtn, 1)
insertUI(
selector = "h5",
where = "beforeEnd",
ui = tagList(variablesUI(paste0("var", btn), btn, columnNames()))
)
newFilter <- callModule(filter, paste0("var", btn))
observeEvent(newFilter(), {
tmpFilters[[paste0("'", btn, "'")]] <- newFilter()
})
})
### \__ Dataset with Filtered Results --------------------------------------
resultsFiltered <- reactive({
req(filter01())
tmpDF <- originalDF()
tmpList <- reactiveValuesToList(tmpFilters)
if (length(tmpList) > 1) {
tmpListFilters <- paste(tmpList, "", collapse = "& ")
} else {
tmpListFilters <- unlist(tmpList)
}
tmpResult <- subset(tmpDF, eval(parse(text = tmpListFilters)))
tmpResult
})
### \__ Print the Dataset with Filtered Results ----------------------------
output$finalTable <- renderTable({
req(input$userDataset)
if (is.null(tmpFilters[['1']])) {
head(originalDF(), 10)
} else {
head(resultsFiltered(), 10)
}
})
}
#------------------------------------------------------------------------------#
shinyApp(ui, server)
# End
If you are looking for a data subsetting/filtering in Shiny Module :
filterData from package shinytools can do the work. It returns an expression as a call but it can also return the data (if your dataset is not too big).
library(shiny)
# remotes::install_github("ardata-fr/shinytools")
library(shinytools)
ui <- fluidPage(
fluidRow(
column(
3,
filterDataUI(id = "ex"),
actionButton("AB", label = "Apply filters")
),
column(
3,
tags$strong("Expression"),
verbatimTextOutput("expression"),
tags$br(),
DT::dataTableOutput("DT")
)
)
)
server <- function(input, output) {
x <- reactive({iris})
res <- callModule(module = filterDataServer, id = "ex", x = x, return_data = FALSE)
output$expression <- renderPrint({
print(res$expr)
})
output$DT <- DT::renderDataTable({
datatable(data_filtered())
})
data_filtered <- eventReactive(input$AB, {
filters <- eval(expr = res$expr, envir = x())
x()[filters,]
})
}
shinyApp(ui, server)
You can also use lazyeval or rlang to evaluate the expression :
filters <- lazyeval::lazy_eval(res$expr, data = x())
filters <- rlang::eval_tidy(res$expr, data = x())
You need to check for existing input values and use them if available:
# Prevent dynamic inputs from resetting
newInputValue <- "Option 1"
if (newInputId %in% names(input)) {
newInputValue <- input[[newInputId]]
}
# Define new input
newInput <- selectInput(newInputId, newInputLabel, c("Option 1", "Option 2", "Option 3"), selected=newInputValue)
A working version of the gist (without the reset problem) can be found here: https://gist.github.com/motin/0d0ed0d98fb423dbcb95c2760cda3a30
Copied below:
ui.R
library(shiny)
shinyUI(pageWithSidebar(
# Application title
headerPanel("Dynamically append arbitrary number of inputs"),
# Sidebar with a slider input for number of bins
sidebarPanel(
uiOutput("allInputs"),
actionButton("appendInput", "Append Input")
),
# Show a plot of the generated distribution
mainPanel(
p("This shows how to add an arbitrary number of inputs
without resetting the values of existing inputs each time a new input is added.
For example, add a new input, set the new input's value to Option 2, then add
another input. Note that the value of the first input does not reset to Option 1.")
)
))
server.R
library(shiny)
shinyServer(function(input, output) {
output$allInputs <- renderUI({
# Get value of button, which represents number of times pressed (i.e. number of inputs added)
inputsToShow <- input$appendInput
# Return if button not pressed yet
if(is.null(inputsToShow) || inputsToShow < 1) return()
# Initialize list of inputs
inputTagList <- tagList()
# Populate the list of inputs
lapply(1:inputsToShow,function(i){
# Define unique input id and label
newInputId <- paste0("input", i)
newInputLabel <- paste("Input", i)
# Prevent dynamic inputs from resetting
newInputValue <- "Option 1"
if (newInputId %in% names(input)) {
newInputValue <- input[[newInputId]]
}
# Define new input
newInput <- selectInput(newInputId, newInputLabel, c("Option 1", "Option 2", "Option 3"), selected=newInputValue)
# Append new input to list of existing inputs
inputTagList <<- tagAppendChild(inputTagList, newInput)
})
# Return updated list of inputs
inputTagList
})
})
(The solution was guided on Nick's hints in the original gist from where you got the code of the promising solution)