Related
I am working on a shiny app that can generate a determined number of UI outputs in form of inputs based on a value defined by the user. Thanks to the help of #YBS I was able to get the app working. But now I face a new issue. Although I could define min and max value for the inputs generated, I would like to add a warning in the inputs when a value is greater than 100, I found shinyfeedback package can do this but I do not where to put properly the code or what to do in the case of dynamic inputs like the ones generated here.
This is the working app:
library(shiny)
library(shinydashboard)
library(DT)
library(shinyFeedback)
#Function
compute <- function(firstitem,seconditem)
{
Sum <- firstitem+seconditem
Difference <- firstitem+seconditem
Product <- firstitem*seconditem
Ratio <- firstitem/seconditem
Res <- data.frame(C1=Sum,C2=Difference,C3=Product,C4=Ratio)
return(Res)
}
#App
ui = shinyUI(fluidPage(
titlePanel("Compare"),
sidebarLayout(
sidebarPanel(
numericInput("numitems", label = "Number of items to compare?",
min = 1, max = 100, value = 1),
uiOutput("period_cutpoints"),
uiOutput("period_cutpoints2"),
actionButton("submit", "Submit")
),
mainPanel(
uiOutput("t1")
)
)
))
server = shinyServer(function(input, output, session) {
output$period_cutpoints<-renderUI({
req(input$numitems)
lapply(1:(input$numitems), function(i) {
numericInput(inputId=paste0("firstitem",i),
label=paste0("Enter the value of first item ", i, ":"),value = i)
})
})
output$period_cutpoints2<-renderUI({
req(input$numitems)
lapply(1:(input$numitems), function(i) {
numericInput(inputId=paste0("seconditem",i),
label=paste0("Enter the value of second item ", i, ":"),value = i+i)
})
})
seldates <- reactiveValues(x=NULL)
observeEvent(input$submit, {
seldates$x <- list()
lapply(1:(input$numitems), function(i) {
seldates$x[[i]] <- compute(firstitem = input[[paste0("firstitem", i)]],seconditem = input[[paste0("seconditem", i)]])
})
})
observeEvent(input$submit, {
lapply(1:(input$numitems), function(i) {
output[[paste0("table",i)]] <- renderDT(seldates$x[[i]])
})
output$t1 <- renderUI({
tagList(
lapply(1:(input$numitems), function(i) {
DTOutput(paste0("table",i))
})
)
})
})
})
shinyApp(ui = ui , server = server)
I tried to add some code inside the dynamic inputs in this way:
#Code demo
output$period_cutpoints<-renderUI({
req(input$numitems)
lapply(1:(input$numitems), function(i) {
numericInput(inputId=paste0("firstitem",i),
label=paste0("Enter the value of first item ", i, ":"),value = i)
})
lapply(1:(input$numitems), function(i) {
observeEvent(input[[paste0('firstitem',i)]], {
shinyFeedback::feedbackWarning(
inputId = paste0('firstitem',i),
show = input[[paste0('firstitem',i)]] > 100,
text = "Number less than 100 required.",
color="red"
)
})
})
})
Unfortunately, this action broke down the app:
And the first input was not generated as you can see.
How can I solve this issue so that I can have warnings when the value is greater than 100? Moreover, this leads to an additional fact, in the action button if working with multiple inputs generated dynamically, how could I do something like this:
#How to extend the if condition so that it can consider the number of inputs defined by the user
observeEvent(input$submit,
{
if(input$firstitem1 < 0 && input$seconditem1 < 0 && input$firstitem2<0 && input$seconditem1<0)
{
showModal(modalDialog(title ="Warning!!!", "Check fields!!!",easyClose = T))
}
else
{
showModal(modalDialog(title ="Congratulations!!!", "Computing Done!!!",easyClose = T))
}
})
How could I change the if so that it considers all the inputs that can be generated.
Many thanks!
I think you have a couple of problems here.
First, you have forgotten to add useShinyFeedback() to your UI definition.
ui = shinyUI(
fluidPage(
useShinyFeedback(),
titlePanel("Compare"),
...
Second, you've put the observeEvents that monitor your first item values inside your renderUI. That's not going to work: R's standard scoping means that these observeEvents won't be available to monitor changes in the corresponding input widgets. The solution is to create a separate observeEvent to create your observers on the inputs:
observeEvent(input$numitems, {
lapply(1:(input$numitems), function(i) {
observeEvent(input[[paste0('firstitem',i)]], {
shinyFeedback::feedbackWarning(
inputId = paste0('firstitem',i),
show = input[[paste0('firstitem',i)]] > 100,
text = "Number less than 100 required.",
color="red"
)
})
})
})
Making these changes gives me, for example,
With regard to your final question about the Submit actionButton, and as a general observation, I think your life will be much easier if you use Shiny modules to solve this problem. This will allow you to delegate the error checking to the indivudual modules and remove the need to continually loop through the indices of the dynamic inputs. This will lead to shorter, simpler, and more understandable code.
One thing to bear in mind if you do this: make sure you put a call to useShinyFeedback in the definition of the module UI.
I'm working on a shiny app and I'm running into difficulty with observeEvent() function when creating a complex expression of multiple inputs that all derive from selectInput().
My issue is some of the expressions within the observeEvent() function are triggered at startup, causing the event to prematurely execute (i.e. my actionButton() is disabled at startup, as it should be, but becomes enabled when at least one of the inputs are selected when ideally I would want it to become enabled only when ALL inputs are selected). As seen below:
observeEvent({
#input$cohort_file
input$cohort_IDvar
input$cohort_index_date
input$cohort_EOF_date
input$cohort_EOF_type
input$cohort_Y_name
input$cohort_L0
}, {
enable("set_cohort_button")
})
For reference, I'm using the shinyjs package by #daattali found on github to enable/disable actionButton().
All but the last input (i.e. input$cohort_L0) appear to be initialized at startup so observeEvent() enables actionButton only when input$cohort_L0 is selected. If you run my app and select input in sequential order from top to bottom, it appears that observeEvent() is working as intended. I only discovered that it wasn't working as intended when I decided to choose inputs at random and discovered that selecting input$cohort_L0 was the only input I needed to select to enable actionButton().
The UI portion of the code looks like this:
# Variable selection
selectInput('cohort_IDvar', 'ID', choices = ''),
selectInput('cohort_index_date', 'Index date', choices = ''),
selectInput('cohort_EOF_date', 'End of follow-up date', choices = ''),
selectInput('cohort_EOF_type', 'End of follow-up reason', choices = ''),
selectInput('cohort_Y_name', 'Outcome', choices = ''),
selectInput('cohort_L0', 'Baseline covariate measurements', choices = '', multiple=TRUE, selectize=TRUE),
And I'm using observe() to collect the column names of an upload data-set to direct them to selectInput() as follows:
### Collecting column names of dataset and making them selectable input
observe({
value <- c("",names(cohort_data()))
updateSelectInput(session,"cohort_IDvar",choices = value)
updateSelectInput(session,"cohort_index_date",choices = value)
updateSelectInput(session,"cohort_EOF_date",choices = value)
updateSelectInput(session,"cohort_EOF_type",choices = value)
updateSelectInput(session,"cohort_L0",choices = value)
})
I've looked into using the argument ignoreInit = TRUE but it does nothing for my case of having multiple expressions within observeEvent(). I've also looked into forcing no default selection in selectInput() but had no luck with that.
So my two-part question is how can I execute observEvent() when only ALL inputs are selected/how do I stop from the inputs from being initialized at startup?
My entire code:
library(shiny)
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
navbarPage("Test",
tabPanel("Cohort",
sidebarLayout(
sidebarPanel(
fileInput("cohort_file", "Choose CSV File",
multiple = FALSE,
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv")),
# Horizontal line ----
tags$hr(),
# Variable selection
selectInput('cohort_IDvar', 'ID', choices = ''),
selectInput('cohort_index_date', 'Index date', choices = ''),
selectInput('cohort_EOF_date', 'End of follow-up date', choices = ''),
selectInput('cohort_EOF_type', 'End of follow-up reason', choices = ''),
selectInput('cohort_Y_name', 'Outcome', choices = ''),
selectInput('cohort_L0', 'Baseline covariate measurements', choices = '', multiple=TRUE, selectize=TRUE),
# Horizontal line ----
tags$hr(),
disabled(
actionButton("set_cohort_button","Set cohort")
)
#actionButton("refresh_cohort_button","Refresh")
),
mainPanel(
DT::dataTableOutput("cohort_table"),
tags$div(id = 'cohort_r_template')
)
)
)
)
)
server <- function(input, output, session) {
################################################
################# Cohort code
################################################
cohort_data <- reactive({
inFile_cohort <- input$cohort_file
if (is.null(inFile_cohort))
return(NULL)
df <- read.csv(inFile_cohort$datapath,
sep = ',')
return(df)
})
rv <- reactiveValues(cohort.data = NULL)
rv <- reactiveValues(cohort.id = NULL)
rv <- reactiveValues(cohort.index.date = NULL)
rv <- reactiveValues(cohort.eof.date = NULL)
rv <- reactiveValues(cohort.eof.type = NULL)
### Creating a reactiveValue of the loaded dataset
observeEvent(input$cohort_file, rv$cohort.data <- cohort_data())
### Displaying loaded dataset in UI
output$cohort_table <- DT::renderDataTable({
df <- cohort_data()
DT::datatable(df,options=list(scrollX=TRUE, scrollCollapse=TRUE))
})
### Collecting column names of dataset and making them selectable input
observe({
value <- c("",names(cohort_data()))
updateSelectInput(session,"cohort_IDvar",choices = value)
updateSelectInput(session,"cohort_index_date",choices = value)
updateSelectInput(session,"cohort_EOF_date",choices = value)
updateSelectInput(session,"cohort_EOF_type",choices = value)
updateSelectInput(session,"cohort_L0",choices = value)
})
### Creating selectable input for Outcome based on End of Follow-Up unique values
observeEvent(input$cohort_EOF_type,{
updateSelectInput(session,"cohort_Y_name",choices = unique(cohort_data()[,input$cohort_EOF_type]))
})
### Series of observeEvents for creating vector reactiveValues of selected column
observeEvent(input$cohort_IDvar, {
rv$cohort.id <- cohort_data()[,input$cohort_IDvar]
})
observeEvent(input$cohort_index_date, {
rv$cohort.index.date <- cohort_data()[,input$cohort_index_date]
})
observeEvent(input$cohort_EOF_date, {
rv$cohort.eof.date <- cohort_data()[,input$cohort_EOF_date]
})
observeEvent(input$cohort_EOF_type, {
rv$cohort.eof.type <- cohort_data()[,input$cohort_EOF_type]
})
### ATTENTION: Following eventReactive not needed for example so commenting out
### Setting id and eof.type as characters and index.date and eof.date as Dates
#cohort_data_final <- eventReactive(input$set_cohort_button,{
# rv$cohort.data[,input$cohort_IDvar] <- as.character(rv$cohort.id)
# rv$cohort.data[,input$cohort_index_date] <- as.Date(rv$cohort.index.date)
# rv$cohort.data[,input$cohort_EOF_date] <- as.Date(rv$cohort.eof.date)
# rv$cohort.data[,input$cohort_EOF_type] <- as.character(rv$cohort.eof.type)
# return(rv$cohort.data)
#})
### Applying desired R function
#set_cohort <- eventReactive(input$set_cohort_button,{
#function::setCohort(data.table::as.data.table(cohort_data_final()), input$cohort_IDvar, input$cohort_index_date, input$cohort_EOF_date, input$cohort_EOF_type, input$cohort_Y_name, input$cohort_L0)
#})
### R code template of function
cohort_code <- eventReactive(input$set_cohort_button,{
paste0("cohort <- setCohort(data = as.data.table(",input$cohort_file$name,"), IDvar = ",input$cohort_IDvar,", index_date = ",input$cohort_index_date,", EOF_date = ",input$cohort_EOF_date,", EOF_type = ",input$cohort_EOF_type,", Y_name = ",input$cohort_Y_name,", L0 = c(",paste0(input$cohort_L0,collapse=","),"))")
})
### R code template output fo UI
output$cohort_code <- renderText({
paste0("cohort <- setCohort(data = as.data.table(",input$cohort_file$name,"), IDvar = ",input$cohort_IDvar,", index_date = ",input$cohort_index_date,", EOF_date = ",input$cohort_EOF_date,", EOF_type = ",input$cohort_EOF_type,", Y_name = ",input$cohort_Y_name,", L0 = c(",paste0(input$cohort_L0,collapse=","),"))")
})
### Disables cohort button when "Set cohort" button is clicked
observeEvent(input$set_cohort_button, {
disable("set_cohort_button")
})
### Disables cohort button if different dataset is loaded
observeEvent(input$cohort_file, {
disable("set_cohort_button")
})
### This is where I run into trouble
observeEvent({
#input$cohort_file
input$cohort_IDvar
input$cohort_index_date
input$cohort_EOF_date
input$cohort_EOF_type
input$cohort_Y_name
input$cohort_L0
}, {
enable("set_cohort_button")
})
### Inserts heading and R template code in UI when "Set cohort" button is clicked
observeEvent(input$set_cohort_button, {
insertUI(
selector = '#cohort_r_template',
ui = tags$div(id = "cohort_insertUI",
h3("R Template Code"),
verbatimTextOutput("cohort_code"))
)
})
### Removes heading and R template code in UI when new file is uploaded or when input is changed
observeEvent({
input$cohort_file
input$cohort_IDvar
input$cohort_index_date
input$cohort_EOF_date
input$cohort_EOF_type
input$cohort_Y_name
input$cohort_L0
}, {
removeUI(
selector = '#cohort_insertUI'
)
})
}
# Run the application
shinyApp(ui = ui, server = server)
The code chunk that you're passing to the observeEvent as the trigger event is
{
input$cohort_IDvar
input$cohort_index_date
input$cohort_EOF_date
input$cohort_EOF_type
input$cohort_Y_name
input$cohort_L0
}
This means that, just like any other reactive code block, when ANY of these values changes, that reactive block is considered invalidated and therefore the observer will trigger. So the behaviour you're seeing makes sense.
It sounds like what you want is to execute only when all values are set. That sounds like a great use of the req() function! Try something like this:
observe({
req(input$cohort_IDvar, input$cohort_index_date, input$cohort_EOF_date, ...)
enable("set_cohort_button")
})
Note that for shinyjs::enable() specifically, you can instead use the shinyjs::toggleState() function. I think in this case the req() function is the better option though.
UPDATE
I've gotten to what I think is the root problem. The following R Shiny App produces a UI with 2 text input boxes, as well as event observers that print messages to the console as the text changes in their respective text input boxes. The issue is that only one of these event observers works correctly, and I can't figure out why.
ui.R (shortened)
library(shiny)
library(shinydashboard)
library(DT)
library(data.table)
shinyUI(
renderUI({
fluidPage(
column(12, dataTableOutput("Main_table")),
box(textInput("TEST_BOX", label=NULL, value="TEST"))
)
})
)
server.R (shortened)
shinyServer(function(input, output) {
test <- reactiveValues()
test$data <- data.table(ID = 1, Group = 1)
output$Main_table <- renderDataTable({
datatable(data.frame(test$data,
New_Group=as.character(textInput("BOX_ID", label = NULL, value = "TEST2",
width = '100px'))), escape=F
)})
observeEvent(input$TEST_BOX, {
print("Test Box Success")
})
observeEvent(input$BOX_ID, {
print("Box ID Success")
})
})
Original Post:
I'm attempting to create a simple app in R Shiny to allow the user to interactively update the values in a column of a small table, then be able to hit a "Save Changes" button and update the table to include their selections.
I've gotten really close with the code below (I think), but for some reason the inputs cbox_1 to cbox_10 always come back as NULL.
ui.R
library(shiny)
library(shinydashboard)
library(DT)
library(data.table)
shinyUI(fluidPage(
dashboardBody(uiOutput("MainBody")
)
))
server.R
# Load libraries
library(shiny)
library(shinydashboard)
library(DT)
library(data.table)
# Define server logic
shinyServer(function(input, output) {
# Create sample data
vals <- reactiveValues()
vals$Data <- data.table(ID = 1:10, Group = 1:1)
# Create main UI with Save Changes button and additional text input box for testing.
output$MainBody <- renderUI({
fluidPage(
box(width=12,
h3(strong("Group Testing"),align="center"),
hr(),
box(textInput("test", label=NULL, value="TESTING")),
column(6, offset = 5, actionButton("save_changes","Save changes")),
column(12, dataTableOutput("Main_table"))
)
)
})
# Function to be used to create multiple text input boxes.
shinyInput = function(FUN, len, id, ...) {
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i), label = NULL, value = vals$Data$Group[i], width = '100px', ...))
}
inputs
}
# Renders table to include column with text input boxes. Uses function above.
output$Main_table <- renderDataTable({
datatable(data.frame(vals$Data, New_Group=shinyInput(textInput, nrow(vals$Data),"cbox_")), options = list(dom = 't', pageLength = nrow(vals$Data), paging=FALSE, searching=FALSE), rownames=FALSE,
escape=F)
}
)
# Tests if the test input box works.
observeEvent(input$test, {
print("Success1")
})
# Tests if the first input box in the table works.
observeEvent(input$cbox_1, {
print("Success2")
})
# Tests if the Save Changes button works.
observeEvent(input$save_changes, {
print("Success3")
# Assigns the values in the input boxes (New_Group) to the existing Group column.
for (i in 1:nrow(vals$Data)) {
vals$Data$Group[i] <- eval(paste0("input$cbox_", i))
}
datatable(data.frame(vals$Data, New_Group=shinyInput(textInput, nrow(vals$Data),"cbox_")), options = list(pageLength = nrow(vals$Data), paging=FALSE, searching=FALSE), rownames=FALSE,
escape=F)
})
})
The first two observeEvents at the end of the code are solely for testing purposes. "Success2" is never printed even when the contents of the first box are changed. "Success1" is printed when the test box is changed, but I'm not sure why one works and the other doesn't. I've tried inserting a browser() statement in various places of the code to check the value of cbox_1, but it always comes back NULL. I'd also be open to alternate solutions to this problem if I'm approaching it completely wrong. Thanks.
After further research, an approach utilizing the rhandsontable package seemed like the best solution. I modeled my code after this example:
Data input via shinyTable in R shiny application
I also utilized several of the options described here:
https://jrowen.github.io/rhandsontable/#introduction
In the shiny application multiple numeric input widgets are generated dynamically each having an initial value inside which are row-column numbers. The sum of those values are also displayed in main panel.
As the user changes the numeric input values the sum updates accordingly. Currently it is instantly. I want to delay the process of inputs in main panel for all numeric inputs by adding action/submit button till I change more than one numeric Inputs.
But I am getting the following error if action/submit buttons are used inside the render functions.
Warning: Error in <<-: number of items to replace is not a multiple of replacement length.
If not inside render functions where else to place as these widgets are generated inside renderUI only.
library(shiny)
ui <- shinyUI(fluidPage(
titlePanel(title = "Use of action/submit button for multiple inputs"),
sidebarLayout(
sidebarPanel(numericInput("rows","Input No. of rows",value = 3,min=1),
br(),
numericInput("col","Input No. of cols",value = 1,min=1)),
mainPanel(textOutput("display"),
uiOutput("plo")
))))
Server.r
server <- function(input,output){
# creating input widgets dynamically
output$plo <- renderUI({
z <- input$col
lapply(seq(input$col), function(j){
column(width=3,
lapply(seq(input$rows),function(i){
numericInput(inputId = paste0("range",paste0(i,j)),label = j,value = paste0(i,j))
})
)
})
})
# capturing the value of input widgets in a matrix
cm <- reactive({
c <- input$col
r <- input$rows
changed_m <- matrix(nrow = r,ncol = c)
lapply(seq(input$col), function(j){
lapply(seq(input$rows),function(i){
changed_m[i,j] <<- input[[paste0("range",paste0(i,j))]]
})
})
changed_m
})
# display the sum
output$display <- renderText({
paste0("Sum of matrix: ",sum(cm()))
})
}
Here is a working example of a possible solution. You can store the string to display (or just the sum of course) in a reactiveVal, and update this only when the user clicks the button, or display an alternative text when one of the inputs has changed so the user knows the sum is no longer correct.
Hope this helps!
library(shiny)
ui <- shinyUI(fluidPage(
titlePanel(title = "Use of action/submit button for multiple inputs"),
sidebarLayout(
sidebarPanel(numericInput("rows","Input No. of rows",value = 3,min=1),
br(),
numericInput("col","Input No. of cols",value = 1,min=1),
actionButton('update' ,'update!')),
mainPanel(textOutput("display"),
uiOutput("plo")
))))
server <- function(input,output){
# creating input widgets dynamically
output$plo <- renderUI({
z <- input$col
lapply(seq(input$col), function(j){
column(width=3,
lapply(seq(input$rows),function(i){
numericInput(inputId = paste0("range",paste0(i,j)),label = j,value = paste0(i,j))
})
)
})
})
# capturing the value of input widgets in a matrix
cm <- reactive({
c <- input$col
r <- input$rows
changed_m <- matrix(nrow = r,ncol = c)
lapply(seq(input$col), function(j){
lapply(seq(input$rows),function(i){
x=input[[paste0("range",paste0(i,j))]]
changed_m[i,j] <<- ifelse(!is.null(x),x,0)
})
})
changed_m
})
# initialize our reactiveVal with an empty string
my_sum <- reactiveVal('')
# observer that listens to the button click, then updates the sum string.
observeEvent(input$update,{
my_sum(paste0("Sum of matrix: ",sum(cm())))
})
# observer that listens to changes in the input, then updates the sum string.
observeEvent(cm(),ignoreNULL = T,ignoreInit = T, {
isolate(my_sum('invalidated. Press button to update.'))
})
# display the sum string
output$display <- renderText({
my_sum()
})
}
shinyApp(ui,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)