I am making a shiny dashboard that contains lots of tables that should appear and behave identically, but contain different data. In order to make my code more modular, I have written a function that will hold the shinyApp() call so that it can be reused. Here is a link to the official shiny documentation showing the use of shinyApp() within a user defined function.
The function works to an extent, because it renders a datatable, but it does not react to changes in the reactive data frame that is input.
Here is the function I have written, along with the libraries I've used and the sidebar that the datatable should be reacting to:
---
title: "Test"
runtime: shiny
output:
flexdashboard::flex_dashboard:
navbar:
orientation: rows
vertical_layout: fill
---
```{r packages, include = FALSE}
library(flexdashboard)
library(DT)
library(dplyr)
library(shiny)
library(datasets)
test_data <- datasets::CO2
data_chart <- function(shiny_data, col_names){
shinyApp(
ui = fluidPage(
DT::dataTableOutput("results")
),
server = function(input, output, session) {
output$results <- DT::renderDataTable(
datatable(
shiny_data,
filter = 'top',
colnames = col_names,
rownames = FALSE,
options = list(
dom = 'lptpi',
scrollY = '',
order = list(3, 'desc')
)
)
)
}
)
}
```
Header
===
Sidebar {.sidebar}
---
```{r}
checkboxGroupInput(
inputId = 'Plant1',
label = h4("Age Group"),
choices = list('Qn1', 'Qn2', 'Qn3', 'Qc1', 'Qc2', 'Qc3', 'Mn1', 'Mn2', 'Mn3', 'Mc1', 'Mc2', 'Mc3'),
selected = c('Qn1', 'Qn2', 'Qn3', 'Qc1', 'Qc2', 'Qc3', 'Mn1', 'Mn2', 'Mn3', 'Mc1', 'Mc2', 'Mc3')
)
```
Row
---
```{r}
data_1 = reactive({test_data %>%
filter(Plant %in% input$Plant1) %>%
data.frame()
})
data_chart(test_data, c('Plant', 'Type', 'Treatment', 'Conc', 'Uptake'))
I think the problem has something to do with the fact that within the function, I refer to the reactive data set "shiny_data()" as "shiny_data" (without parenthesis), which makes it behave statically. However, I have tried adding the parenthesis and I get the error:
ERROR: could not find function "shiny_data()"
Furthermore, I have tried wrapping various sections of the code with reactive({}) to try to explicitly define the data as reactive, but with no luck.
I'm confident this isn't an issue with having the shinyApp() within a function, because when I make a function that I have hard coded the reactive data_1() data frame, it reacts to changes in the sidebar. Here is an example of this result (the function is exactly the same as above, but instead of passing shiny_data into the function, data_1() is hardcoded in):
Row
---
```{r}
data_chart2 <- function(col_names){
shinyApp(
ui = fluidPage(
DT::dataTableOutput("results")
),
server = function(input, output, session) {
output$results <- DT::renderDataTable(
serverTable <- datatable(
data_1(),
filter = 'top',
colnames = col_names,
rownames = FALSE,
options = list(
dom = 'lptpi',
scrollY = '',
order = list(3, 'desc')
)
)
)
}
)
}
data_chart2(c('Plant', 'Type', 'Treatment', 'Conc', 'Uptake'))
```
As you can see in both provided examples, the data in the rendered datatable only reacts when the reactive dataset is explicitly called in the function. is there any way that at the time the data is input into/called by the user defined function, it can be treated as a reactive element?
Thank you for you help!
To be able to pass a reactive to a function, you need to pass it without brackets.
data_chart(data_1, c('Plant', 'Type', 'Treatment', 'Conc', 'Uptake'))
You can use it within the function with the name of the argument + brackets: shiny_data()
Full data_chart function:
data_chart <- function(shiny_data, col_names){
shinyApp(
ui = fluidPage(
DT::dataTableOutput("results")
),
server = function(input, output, session) {
output$results <- DT::renderDataTable(
datatable(
shiny_data(),
filter = 'top',
colnames = col_names,
rownames = FALSE,
options = list(
dom = 'lptpi',
scrollY = '',
order = list(3, 'desc')
)
)
)
}
)
}
Output
Related
I am trying to pass input$myInput text field to a custom function as a predefined argument. This is important to control the functions arguments in future for documentation (roxygen2).
Here is a minimal working example:
The app schould bind the input field to mtcars dataset and apply the custom function my_DTarguments with two arguments (1. data, 2. input):
library(shiny)
library(DT)
#function
my_DTarguments <- function(data, input=input$myInput) {
DT::datatable(
rownames = FALSE,
data,
extensions = 'Buttons',
options = list(
dom = 'frtipB',
buttons = list(
list(
extend = 'csv',
filename = paste0("mydesiredname-", "cyl-", input, "-", Sys.Date())
),
)
)
)
}
shinyApp(
ui <- fluidPage(
textInput(inputId = "myInput", label = "My Input", placeholder = "a"),
DT::dataTableOutput("table")
),
server <- function(input, output) {
# combine mtcars with input field
mtcars1 <- reactive({
cbind(mtcars, input$myInput)
})
# apply function to mtcars1
output$table <- DT::renderDataTable(
my_DTarguments(mtcars1())
)
})
}
)
The last error after many tries is : promise already under evaluation: recursive default argument reference or earlier problems?
The thing with reactive expressions is that Shiny adds them to the reactive chain and then evaluates all reactive expressions in the chain one by one. We do not know the order in which Shiny does that.
In your case, Shiny tries to evaluate renderDataTable and by doing so calls my_DTarguments(). However, myInput has not been evaluated, yet, hence the error.
When you use a reactive expressions as a default function argument, you should always add a in a req(...) call (example: req(input$myInput)). But you still have to add input$myInput in the call to my_DTarguments() from renderDataTable. But you'll get an empty column, if input$myInput is still empty.
Alternatively, you can make sure that input$myInput is truthy before calling my_DTarguments. In this case, the table will only be shown once input$myInput is not empty and Shiny has already evaluated it.
Personally I think the secnond is the cleaner approach. I recommend that we do not use reactive expressions as default arguments for functions, in general. Not only does it violate the idea of a default argument when the caller has to add it anyway. The way reactive expressions work they are only available in the runtime environment as needed. A default argument, however, should be available anytime a function is called. That is like adding a predetermined breaking point in our code ... which - of course - we don't want.
library(shiny)
library(DT)
#function
my_DTarguments <- function(data, input=req(input$myInput)) {
DT::datatable(
rownames = FALSE,
data,
extensions = 'Buttons',
options = list(
dom = 'frtipB',
buttons = list(
#list(
extend = 'csv',
filename = paste0("mydesiredname-", "cyl-", input, "-", Sys.Date())
#),
)
)
)
}
shinyApp(
ui <- fluidPage(
textInput(inputId = "myInput", label = "My Input", placeholder = "a"),
DT::dataTableOutput("table")
),
server <- function(input, output) {
# combine mtcars with input field
mtcars1 <- reactive({
cbind(mtcars, input$myInput)
})
# apply function to mtcars1
output$table <- DT::renderDataTable({
my_DTarguments(mtcars1())
# Alternative approach: call req() here
# my_DTarguments(mtcars1(), req(input$myInput))
})
}
)
By the way, there seems to be an issue with the buttons option. I commented 2 lines out, so that the code runs.
I've this Shiny code example:
library(shiny)
library(DT)
x = read.xlsx("my_path\\2.xlsx") #my file I want to use
shinyApp(
ui = fluidPage(
fluidRow(
column(12,
DTOutput('table')
)
)
),
server = function(input, output) {
output$table <- renderDT(iris,
filter = "top",
options = list(
pageLength = 5
)
)
}
)
When I click on some filter I get a list of all the possible values:
But when I use my file (x), instead of iris - it doesn't work and the list doesn't open
any idea how to fix it?
Try something like this with the column you want to make searchable:
x$column <- as.factor(x$column)
The Species column in the Iris dataset is a factor; when using character columns, DT will allow you to type in possible values.
I want to display a table in Shiny with renderDataTable() function. For each row I want to create 2 checkboxes. I'm using checkboxInput() function to create those checkboxes.
The checkboxes are created, but when I'm trying to read them with input$checkbox_id, I get NULL.
The same trick works using renderTable(), but my client wants the extra features of DT table (sorting, filtering).
If I inspect the HTML generated, I see that renderTable() inserts and extra class="shiny-bound-input" into the tag. renderDataTable() does not.
library(shiny)
shinyApp(
ui = fluidPage(
fluidRow(
column(12,dataTableOutput('dataTableOutput')),
column(12,tableOutput('tableOutput')),
actionButton('printCheckStatus','printCheckStatus')
)
),
server = function(input, output) {
df1 <- data.frame(CheckBoxColumn=as.character(checkboxInput("id_1",NULL)))
df2 <- data.frame(CheckBoxColumn=as.character(checkboxInput("id_2",NULL)))
output$dataTableOutput <- renderDataTable(df1,escape = FALSE)
output$tableOutput <- renderTable(df2, sanitize.text.function = function(x) x)
observeEvent(input$printCheckStatus, {print(input$id_1);print(input$id_2)})
}
)
The code generates a button and two tables each containing one checkbox.
When I click the button I get NULL and FALSE in the console. FALSE is correct, because the second checkbox is unchecked. I get NULL because input$id_1 does not exist in the Shiny server session.
I expect FALSE and FALSE in the console log.
You can use the DT package (based on this):
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
fluidRow(
column(12,dataTableOutput('dataTableOutput')),
column(12,tableOutput('tableOutput')),
actionButton('printCheckStatus','printCheckStatus')
)
),
server = function(input, output) {
df1 <- data.frame(CheckBoxColumn=as.character(checkboxInput("id_1",NULL)))
df2 <- data.frame(CheckBoxColumn=as.character(checkboxInput("id_2",NULL)))
output$dataTableOutput <- renderDataTable(df1,escape = FALSE, server = FALSE,
callback = JS("table.cells().every(function(i, tab, cell) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-checkbox');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());"))
output$tableOutput <- renderTable(df2, sanitize.text.function = function(x) x)
observeEvent(input$printCheckStatus, {print(input$id_1);print(input$id_2)})
}
)
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.
I would like to dynamically create a series of input widgets to use in each row of data table. I am successfully able to display such a list of inputs in the table, however I'm having trouble accessing the value of these dynamic inputs.
ui.R
library(shiny)
ui <- fluidPage(
fluidRow(
radioButtons('original','Normal Radio Button',c('1','2','3','4','5')),
DT::dataTableOutput("table")
)
)
server.R
library(DT)
multipleRadio <- function(FUN, id_nums, id_base, label, choices, ...) {
inputs <- 1:length(id_nums)
for (i in 1:length(inputs)) {
inputs[i] <- as.character(FUN(paste0(id_base, id_nums[i]),label, choices, ...))
}
return(inputs)
}
radio_inputs <- multipleRadio(radioButtons,
as.character(1:3),
'input_',
'Radio Button',
c('1','2','3','4','5'),
inline = TRUE)
output_table <- data.frame(id = c(1,2,3),
name=c('Item 1','Item 2','Item 3'),
select = radio_inputs)
server <- function(input, output, session) {
observe({
print(paste('original: ',input$original))
print(paste('input 1: ',input$input_1))
print(paste('input 2: ',input$input_2))
print(paste('input 3: ',input$input_3))
})
output$table <- renderDataTable({
datatable(output_table,rownames= FALSE,escape = FALSE,selection='single',
options = list(paging = FALSE,ordering=FALSE,searching=FALSE))
})
}
I define a function which generates multiple radioButton inputs and converts them into their HTML representation using as.character. This generates a series of inputs whose ids are "input_1", "input_2", and "input_3." I fill a column of the output table with the radio inputs. The display of the radioButtons works as expected. I see one in each row. However, input$input_1,input$input_2, and input$input_3 don't seem to exist and there is no response to clicking on these buttons. Any tips on what's going wrong here would be greatly appreciated!
Edit:
I found a solution here:
http://www.stackoverflow.red/questions/32993257/shiny-datatables-with-interactive-elements
Using the Shiny.bindAll function when rendering the datatable appears to convert the HTML inputs into Shiny input objects.
output$table <- renderDataTable({
datatable(output_table,rownames= FALSE,escape = FALSE,selection='single',
options = list(paging = FALSE,ordering=FALSE,searching=FALSE,
preDrawCallback=JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback=JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
})
A correct shiny input object is a shiny.tag object, which you cannot put into a data.frame. If you do so, you'll get the following error message:
Error in as.data.frame.default(x[[i]], optional = TRUE,
stringsAsFactors = stringsAsFactors) : cannot coerce class
""shiny.tag"" to a data.frame
In your example, the radio_inputs object you get is in fact a list of character, which is pure HTML code. Thus you still get the UI, but they no longer work as shiny inputs.
I guess the only way is to use a pure HTML table if you want radio buttons or any other shiny input objects inside a table.