I am trying to implement user feedback for an app I'm working on using the shinyvalidate package. Some of the feedback I want to communicate to the user is whether a value they have selected is within a specific range or not. The range of interest depends on another input they have made (I have included a simplified repex of the code).
Thus, whether the precondition of interest is met depends on a reactive value. I first define a function that checks whether a provided value is within a specified range. Then I call this function within add_rule() using a reactive as an argument to the function. This results in an error, which states that I cannot access the reactive using add_rule. This is supposedly the case because the InputValidator object is not a reactive consumer.
Error message:
Warning: Error in Can't access reactive value 'num1' outside of reactive consumer.
i Do you need to wrap inside reactive() or observer()?
55: <Anonymous>
Error: Can't access reactive value 'num1' outside of reactive consumer.
i Do you need to wrap inside reactive() or observer()?
However, if I use an unnamed function within add_rule(), I can specify a range that depends on a reactive and I no longer get the error message. The unnamed and named functions I use are identical and I don't understand why I get an error message using a named function but I do not get the error message when using the named function.
Here is my code using the named function:
library(shiny)
library(shinyvalidate)
checkRange <- function(value, value2){
if(value < -2 * value2 || value > 2 * value2 ){
paste0("Please specify a number that is within the range: ", -2 * value2, ":", 2 * value2, " - Tank you!")
}
}
ui <- fluidPage(
fluidRow(
numericInput("num1",
"Please specify your first number",
value = NULL),
numericInput("num2",
"Please specify a different number",
value = NULL),
verbatimTextOutput("selectedNums")
)
)
server <- function(input, output, session){
iv <- InputValidator$new()
iv$add_rule("num1", sv_required())
iv$add_rule("num2", sv_required())
iv$add_rule("num2", checkRange, value2 = input$num1)
iv$enable()
output$selectedNums <- renderPrint({
req(iv$is_valid())
paste0("The first number = ", input$num1, " and the second number = ", input$num2)
})
}
app <- shinyApp(ui, server)
runApp(app)
And here is the code using an anonymous function (UI and server code are largely identical except one call to iv$add_rule()):
library(shiny)
library(shinyvalidate)
ui <- fluidPage(
fluidRow(
numericInput("num1",
"Please specify your first number",
value = NULL),
numericInput("num2",
"Please specify a different number",
value = NULL),
verbatimTextOutput("selectedNums")
)
)
server <- function(input, output, session){
iv <- InputValidator$new()
iv$add_rule("num1", sv_required())
iv$add_rule("num2", sv_required())
iv$add_rule("num2", function(value){
if(value < - 2 * input$num1 || value > 2 * input$num2){
paste0("Please specify a number that is within the range: ", -2 * input$num1, ":", 2 * input$num1, " - Tank you!")
}
})
iv$enable()
output$selectedNums <- renderPrint({
req(iv$is_valid())
paste0("The first number = ", input$num1, " and the second number = ", input$num2)
})
}
app <- shinyApp(ui, server)
runApp(app)
I would prefer to use the named function since I would like to reuse the code multiple times. Could anyone help me out as to why I get an error message with the named function but not with the unnamed one?
You could do:
iv$add_rule("num2", function(value){checkRange(value, input$num1)})
The objective of the application is for the user to select some variables from the selectinput function in rshiny and based on whatever variables are selected there should be a corresponding numericinput box which takes the weightage of that variable as input.
So for example if I select four variable from the selectinput function then there should be 4 numericinput boxes which would prompt the user to enter the corresponding weightages.
I am able to do this using the checkbox option instead of selectinput function, but since the number of variables are huge checkbox option is not viable.
Using checkbox function the codes is as follows:
checkboxInput("pick", "Picked_up"),
conditionalPanel(
condition = "input.pick == true",
numericInput("var1","Enter the weightage of the variable","")
),
br(),
checkboxInput("c2", "%C2"),
conditionalPanel(
condition = "input.c2 == true",
numericInput("var2","Enter the weightage of the variable","")
),
br(),
checkboxInput("newfill", "Perc_Newfill"),
conditionalPanel(
condition = "input.newfill == true",
numericInput("var3","Enter the weightage of the variable","")
),
br(),
checkboxInput("rts", "%RTS"),
conditionalPanel(
condition = "input.rts == true",
numericInput("var4","Enter the weightage of the variable","")
)
I want to implement the same functionality for selectinput function, the code I tried is as follows:
ui.r
uiOutput('select_value'),
uiOutput('input_value'),
server.r
output$select_value <- renderUI({
selectInput('var_name','choose variables',names(descriptive_data),multiple = TRUE)
})
runInput2<- observeEvent(input$var_name,{
for(i in 1:length(input$var_name))
{
output$input_value <- renderUI({
mydata <- input$var_name[1]
numericInput('var', 'input weightage',"")
})
}
})
I am new to Rshiny and hence would be open to inputs suggestions as to what I am doing wrong and how can i implement this.
Here is a solution for your problem. It creates a numericInput for each variable selected. Instead of using a for loop, it uses a lapply function which return a list with all the UI elements created (this is the best way to group multiple UI elements). Finally, to avoid create multiple observers to get the values of the numericInput's, it uses an action button to recover the values only if the variable was selected. At the beginning of the server function, a vector was created to store the predefined weight values, it also is useful to restore the value of a numericInput previously assigned by the user. This is necessary because every time a new variable is selected, the full mainPanel is rendered again.
library(shiny)
ui <- fluidPage(
sidebarPanel(uiOutput('select_value')),
mainPanel(uiOutput('input_value'))
)
server <- function(input , output){
descriptive_data <- mtcars
# initial value for weights and to keep track of value
weightages <- rep(0, ncol(descriptive_data))
# set names to simplify recover/storing value
names(weightages) <- names(descriptive_data)
output$select_value <- renderUI({
div(
selectInput('var_name', 'choose variables',
names(descriptive_data), multiple = TRUE),
actionButton("get", "Get weightages"),
tableOutput('table')
)
})
output$input_value <- renderUI({
var_name <- input$var_name
if (!is.null(var_name)) {
# lapply will return a list
lapply(1:length(var_name), function(k) {
numericInput(paste0("var", k),
paste('input weightage for',
# assign stored value
var_name[k]), weightages[[var_name[k]]])
})
}
})
observeEvent(input$get, {
# to avoid create one observer per numeric input
# we use a action button to trigger the recovering
# of weights.
var_name <- input$var_name
if (!is.null(var_name)) {
for(k in 1:length(var_name)) {
# only recover/update value is the numeric input exists
if (!is.null(input[[paste0("var", k)]]))
weightages[[var_name[k]]] <<- input[[paste0("var", k)]]
}
}
# show current weights
output$table <- renderTable(data.frame(
variable = names(descriptive_data),
weightages))
})
}
shinyApp(ui = ui , server = server)
I have a series of inputs in my R Shiny app that I am using as arguments to a function to select specific data from a data frame. On of the inputs is dateInput:
dateInput("dateSelect", "Date", format = "yyyy-mm-dd", value = NA)
In my function, I need to specify if dateSelect is blank or not selected, to be able select All dates. See an example that is working correctly, that isn't a date, and a simple selectInput:
selectInput("teamSelect", "Team", choices = c("All", levels(newEffortstable$team)))
In the function, this works to select 'All teams':
if(!missing(teamSelect)){
if(teamSelect!="All"){
selections[["teamEfforts"]] =
newEffortstable$effortNo[which(newEffortstable$team %in% teamSelect)]
}else{
selections[["teamEfforts"]] = newEffortstable$effortNo
}
}
I have tried the following with NA and NULL and " " and keep getting 'Error in if: argument is of length zero'
if(!missing(dateSelect)){
if(!dateSelect== "NA"){
selections[["dateEfforts"]] =
newEffortstable$effortNo[which(newEffortstable$date == dateSelect)]
}else{
selections[["dateEfforts"]] = newEffortstable$effortNo
}
}
Thanks!
There's one option you didn't try out yet: checking the length. When no date is given, dateInput returns an empty Date vector as illustrated in the example below.
So you could check if(length(input$dateSelect) == 0), but this is not the most solid shiny option. In order to avoid that you have to check all possibilities (i.e. NULL, NA, "", numeric(0) etc), you can use the function isTruthy() as in the example below:
shinyApp(
ui = fluidPage(
dateInput("dateSelect","Date"),
verbatimTextOutput("out"),
textOutput("text")
),
server = function(input,output,session){
output$text <- renderText({
if(!isTruthy(input$dateSelect)){
"NO DATE"
} else {
paste("The chosen date is:",input$dateSelect)
}
})
output$out<- renderPrint({str(input$dateSelect)})
}
)
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)
I try to populate a list on shiny with the elements of the list passed over from a shiny input. The list should accumulate all the made choices. The list should finally be sent to the shiny output. Actually I already get a list which I can send to output. This list is however always just of length one and this single element gets updated as the input does. Actually I am only interested in the "names" of the list, this is why I assign the value 1 to each name element:
UI.R
shinyUI(
fluidRow(
column(1,
# reactive input
selectInput("Input1",
label = "Select Parameter 1",
choices = c("none",letters[1:16]),
multiple = T),
selectInput("Input2",
label = "Select Parameter 2",
choices = c("none",c(1:24) )
multiple = T),
# printout of list
htmlOutput("printoutList")
) # end of column
) # end of fluid row
) # end of Shiny UI
Shiny.R
# create an empty list
container <- list()
shinyServer(function(input, output) {
# pass over input to reactive
inputInfo <- reactive({
if(input$Input1 == "none" | input$Input2 == "none") {
"-"
} else {
paste(input$Input1 ,input$Input2, sep = "")
}
})
# fill list and pass over list to output
output$printoutList <- renderUI({
container[[inputInfo()]] <- 1
paste("You have chosen: ", names(container), sep = "")
})
)} #end of shinyServer function
Any idea how to solve this? I already tried around a lot... unfortunately I am quite new to R, especially to shiny ! I would really appreciate any kind of help! Thanks !
include the multiple = TRUE argument for selectInput
selectInput("Input1",
label = "Select Parameter 1",
choices = c("none",letters[1:16]),
multiple = TRUE
)
But also it seems like your server and ui files are mixed up and you don't have the shinyServer function in the code.