Related
I am writing a Shiny program which manipulates a dataset the user uploads.
The dataset has fixed column names and I create several UI elements (selectInputs) to filter that dataset.
Reprex looks like this:
ui <- fluidPage(
fluidRow(selectInput("filter_a","label",choices = c("a","b","c"),multiple = T),
selectInput("filter_b","label",choices = c("x","z","y"),multiple = T),
dataTableOutput("o1"),
br(),
dataTableOutput("o2")
)
)
server <- function(input, output) {
df <- reactive({
df <- data.frame(a = c("a","b","c"),
b = c("x","z","y"))
})
filter_function_1 <- reactive({
req(data)
df <- df()
if(!is.null(input$filter_a)){
df <- df %>%
filter(df$a %in% input$filter_a)
}
if(!is.null(input$filter_b)){
df <- df %>%
filter(df$b %in% input$filter_b)
}
return(df)
})
output$o1 <- renderDataTable({filter_function_1()})
While this works it looks like very bad practice. In my actual program I have a set of 14 filters and wrapping it 14 times and applying the same just doesnt look right to me.
Wanting to simplify I came up with this. I have a feeling that this is also not best practice (addressing the input$filter_a by concatenating strings doesnt seem right).
filter_func <- function(df, arg) {
filter_arg <- paste0("filter_", arg)
filter <- paste0("input$", filter_arg)
if (!is.null(eval(parse(text = filter)))) {
df <- df %>%
filter(df[[arg]] %in% input[[filter_arg]])
}
return(df)
}
filter_function_2 <- reactive({
df <- df()
df <- df %>%
filter_func(arg="a") %>%
filter_func(arg="b")
return(df)
})
output$o2 <- renderDataTable({filter_function_2()})
}
Now, this looks cleaner to me, but I still want to modulize the code even more and have the filter function and code resign in a file. There are more data prep steps involved and I want to be able to debug them easily, hence the separate files / functions.
Code might look now like this:
filter_data.R
filter_func <- function(df, arg) {
filter_arg <- paste0("filter_", arg)
filter <- paste0("input$", filter_arg)
if (!is.null(eval(parse(text = filter)))) {
df <- df %>%
filter(df[[arg]] %in% input[[filter_arg]])
}
return(df)
}
This is the point where it doesn't work anymore, since it can't find the input while in the function scope - that would be at least my best guess. I though of rewriting function in several ways, these are my ideas:
Have the filer_data.R function take in named arguments for all columns I want to filter. This seems straight-forward but also very redundant to me
Access shiny input variable on the server side, collect all "columns" that start with "filter_" and pass them onto the filter function. The filter function then applies the necessary filters.
I'm pretty sure I mess up somewhere, but I haven't been able to figure it out. What's not working here?
First, lets solve the problem how to call several filter in a row based on multiple inputs. We can use purrr:reduce2 for this:
In the example below reduce2 takes a custom function called myfilter with three arguments: the initial data.frame the column name and the value we want to filter. When calling reduce2 it is important to supply the data.frame to the .init argument.
library(shiny)
library(tidyverse)
myfilter <- function(df, col, vals) {
if(!is.null(vals)) {
filter(df, !!sym(col) %in% vals)
} else {
df
}
}
shinyApp(ui = fluidPage(
fluidRow(selectInput("filter_a","label", choices = c("a","b","c"), multiple = TRUE),
selectInput("filter_b","label", choices = c("x","z","y"), multiple = TRUE),
dataTableOutput("o1"),
br(),
dataTableOutput("o2")
)
),
server = function(input, output) {
df <- reactive({
df <- data.frame(a = c("a","b","c"),
b = c("x","z","y"))
})
filter_function_1 <- reactive({
req(data)
filter_ls <- map(set_names(grep("^filter", names(input), value = TRUE)), ~ input[[.x]])
col_nms <- gsub("^filter_", "", names(filter_ls))
reduce2(col_nms,
filter_ls,
myfilter,
.init = df())
})
output$o1 <- renderDataTable({filter_function_1()})
})
Then we could create a separate function filter_function_1 with two arguments: react_dat and input.
library(shiny)
library(tidyverse)
myfilter <- function(df, col, vals) {
if(!is.null(vals)) {
filter(df, !!sym(col) %in% vals)
} else {
df
}
}
filter_function_1 <- function(reac_dat, input) {
reactive({
filter_ls <- map(set_names(grep("^filter", names(input), value = TRUE)),
~ input[[.x]])
col_nms <- gsub("^filter_", "", names(filter_ls))
reduce2(col_nms,
filter_ls,
myfilter,
.init = reac_dat)
})
}
shinyApp(ui = fluidPage(
fluidRow(selectInput("filter_a","label", choices = c("a","b","c"), multiple = TRUE),
selectInput("filter_b","label", choices = c("x","z","y"), multiple = TRUE),
dataTableOutput("o1"),
br(),
dataTableOutput("o2")
)
),
server = function(input, output) {
df <- reactive({
df <- data.frame(a = c("a","b","c"),
b = c("x","z","y"))
})
filter_dat <- filter_function_1(df(), input = input)
output$o1 <- renderDataTable({filter_dat()})
})
And another way cleaning the code by putting it in external function / files would be to use shiny modules. There are many ways to set this up depending on how this module interacts with other parts of your app. One way of doing this is putting everything into the module:
library(shiny)
library(tidyverse)
myfilter <- function(df, col, vals) {
if(!is.null(vals)) {
filter(df, !!sym(col) %in% vals)
} else {
df
}
}
filterFunUI <- function(id) {
tagList(
fluidRow(selectInput(NS(id, "filter_a"),"label", choices = c("a","b","c"), multiple = TRUE),
selectInput(NS(id, "filter_b"),"label", choices = c("x","z","y"), multiple = TRUE),
dataTableOutput(NS(id, "o1")),
br(),
dataTableOutput(NS(id, "o2")))
)
}
filterFunServer <- function(id) {
moduleServer(id, function(input, output, session) {
df <- reactive({
df <- data.frame(a = c("a","b","c"),
b = c("x","z","y"))
})
filter_dat <- reactive({
filter_ls <- map(set_names(grep("^filter", names(input), value = TRUE)),
~ input[[.x]])
col_nms <- gsub("^filter_", "", names(filter_ls))
reduce2(col_nms,
filter_ls,
myfilter,
.init = df())
})
output$o1 <- renderDataTable({filter_dat()})
})
}
ui <- fluidPage(filterFunUI("first"))
server <- function(input, output, session) {
filterFunServer("first")
}
shinyApp(ui = ui, server = server)
I am very new to Shiny and struggle to understand reactivity.
Context : I want user to choose a name for a column, add this column to a reactive table and then edit this table. The table is reactive (it comes from an uploaded file filtered by user).
Thanks to this answer everything work fine with a non-reactive table (see mydata <- mtcars[1:5,]).
But it doesn't work when mydata becomes reactive!
Here is a reproductible working example with NON-REACTIVE data from #dww answer:
library(rhandsontable)
ui <- fluidPage(
h2("The mtcars data"),
rHandsontableOutput("mytable"),
textInput('NewCol', 'Enter new column name'),
radioButtons("type", "Column type:",
c("Integer" = "integer",
"Floating point" = "numeric",
"Text" = "character")),
actionButton("goButton", "Update Table")
)
server <- function(input, output) {
mydata <- mtcars[1:5,]
output$mytable = renderRHandsontable(df())
df <- eventReactive(input$goButton, {
if(input$NewCol!="" && !is.null(input$NewCol) && input$goButton>0){
if (input$type == "integer") v1 <- integer(NROW(mydata))
if (input$type == "numeric") v1 <- numeric(NROW(mydata))
if (input$type == "character") v1 <- character(NROW(mydata))
newcol <- data.frame(v1)
names(newcol) <- input$NewCol
mydata <<- cbind(mydata, newcol)
}
rhandsontable(mydata, stretchH = "all")
}, ignoreNULL = FALSE)
observe(if (!is.null(input$mytable)) mydata <<- hot_to_r(input$mytable))
}
shinyApp(ui,server)
I have unsuccessfully tried these changes inside the code (basically I have changed all mydata for mydata()):
server <- function(input, output) {
# mydata <- reactive({ }) #make mydata a reactive object
output$mytable = renderRHandsontable(df())
df <- eventReactive(input$goButton, {
if(input$NewCol!="" && !is.null(input$NewCol) && input$goButton>0){
if (input$type == "integer") v1 <- integer(NROW(mydata()))
if (input$type == "numeric") v1 <- numeric(NROW(mydata()))
if (input$type == "character") v1 <- character(NROW(mydata()))
newcol <- data.frame(v1)
names(newcol) <- input$NewCol
mydata <<- cbind(mydata(), newcol)
}
rhandsontable(mydata(), stretchH = "all")
}, ignoreNULL = FALSE)
observe(if (!is.null(input$mytable)) mydata() <<- hot_to_r(input$mytable))}
I did not find this question answers/comments useful to answer my problem).
Could you explain how to use a reactive mydata inside #dww awesome answer?
[EDIT : title updated to better fit the answer]
I trimmed some extra features, like column data types... As a general rule - anything which you'd be rendering, can become reactive just by wrapping it in "reactive". Below I use "reactiveValues" but other reactive methods would work too.
A generalised way of making your output reactive to changes in the data's input -
foo_func = function() return(mydata)
foo_func_reactive = reactive(foo_func)
output$foo = renderMethod( foo_func_reactive() )
For your example:
shinyApp(
ui = fluidPage(
rHandsontableOutput("out_tbl"),
textInput(inputId = "in_txt", label = "New column name"),
actionButton(inputId = "in_btn1", label = "Add new column to the table above ..."),
actionButton(inputId = "in_btn2", label = "... Or, generate new data")
),
server = function(input, output, session) {
# establishes tbl_react as the holder for our reactive data, and pre-fills it for the first display with 1,2,3
tbl_react <- reactiveValues(tbl =
data.frame(a = c(1,2,3))
)
# button one adds a new column with the inputted name
observeEvent(input$in_btn1,{
newcolname <- as.character(input$in_txt)
newcol <- character(NROW(tbl_react$tbl))
tbl_react$tbl <- cbind(tbl_react$tbl, newcol)
colnames(tbl_react$tbl) <- c(colnames(tbl_react$tbl)[1:ncol(tbl_react$tbl)-1], newcolname)
})
# to show our output data is reactive, we can take a dependancy on button two to generate new data - this could instead be using an uploaded file
observeEvent(input$in_btn2,{
tbl_react$tbl <- data.frame(b = c(9,10,11))
})
output$out_tbl = renderRHandsontable( rhandsontable(tbl_react$tbl) )
}
)
I have a global data-frame (it would be defined in Global.R) that is constructed by querying a postgre database. This data-frame needs to be shared across multiple sessions.
Now in the UI, of each session, I need to display a data table with the contents of this data frame. I also have a radioButton object so that the user can change the value of a field, call it decision in the data-frame for a given row, and I would like the corresponding line in the data table to be displayed or not (i.e. display the data-frame row as a line in the datatable if decision == 0 only)
Problem:
I would like the line in the datatable to be reactively hidden/displayed according to the value the user gives to decision and I would like that to happen across multiple sessions
So if there are 2 users and user_1 changes the value of decision for row a from 0 (displayed) to 1 (hidden), I would like that row to be reactively hidden in the datatables of BOTH user_1 AND user_2 without either of them having to refresh or press an actionButton.
What would be the best way to go about this?
Here's a minimal reproducible example:
library(shiny)
library(dplyr)
# global data-frame
df <<- data.frame(id = letters[1:10], decision = 0)
update_decision_value <- function (id, dec) {
df[df$id == id, "decision"] <<- dec
}
ui <- fluidPage(
uiOutput('select_id'),
uiOutput('decision_value'),
dataTableOutput('my_table')
)
server <- function(input, output, session) {
filter.data <- reactive({
df %>%
filter(decision == 0)
})
output$select_id <- renderUI({
selectInput('selected_id', "ID:", choices = df$id)
})
output$decision_value <- renderUI({
radioButtons(
'decision_value',
"Decision Value:",
choices = c("Display" = 0, "Hide" = 1),
selected = df[df$id == input$selected_id, "decision"]
)
})
output$my_table <- renderDataTable({
filter.data()
})
observeEvent(input$decision_value, {
update_decision_value(input$selected_id, input$decision_value)
})
}
shinyApp(ui, server)
Here is a working example:
library(shiny)
library(dplyr)
library(RSQLite)
# global data-frame
df <- data.frame(id = letters[1:10], decision = 0, another_col = LETTERS[1:10])
con <- dbConnect(RSQLite::SQLite(), "my.db", overwrite = FALSE)
if (!"df" %in% dbListTables(con)) {
dbWriteTable(con, "df", df)
}
# drop global data-frame
rm("df")
update_decision_value <- function (id, dec) {
dbExecute(con, sprintf("UPDATE df SET decision = '%s' WHERE id = '%s';", dec, id))
}
ui <- fluidPage(textOutput("shiny_session"),
uiOutput('select_id'),
uiOutput('decision_value'),
dataTableOutput('my_table'))
server <- function(input, output, session) {
output$shiny_session <- renderText(paste("Shiny session:", session$token))
session$onSessionEnded(function() {
if (!is.null(con)) {
dbDisconnect(con)
con <<- NULL # avoid warning; sqlite uses single connection for multiple shiny sessions
}
})
df_ini <- dbGetQuery(con, "SELECT id, decision FROM df;")
all_ids <- df_ini$id
df <- reactivePoll(
intervalMillis = 100,
session,
checkFunc = function() {
req(con)
df_current <- dbGetQuery(con, "SELECT id, decision FROM df;")
if (all(df_current == df_ini)) {
return(TRUE)
}
else{
df_ini <<- df_current
return(FALSE)
}
},
valueFunc = function() {
dbReadTable(con, "df")
}
)
filter.data <- reactive({
df() %>%
filter(decision == 0)
})
output$select_id <- renderUI({
selectInput('selected_id', "ID:", choices = all_ids)
})
output$decision_value <- renderUI({
radioButtons(
'decision_value',
"Decision Value:",
choices = c("Display" = 0, "Hide" = 1),
selected = df()[df()$id == input$selected_id, "decision"]
)
})
output$my_table <- renderDataTable({
filter.data()
})
observeEvent(input$decision_value, {
update_decision_value(input$selected_id, input$decision_value)
})
}
shinyApp(ui, server)
Edit ------------------------------------
Updated version which reduces load on the db by avoiding to compare the entire table and instead only searches shiny-session-wise unkown changes (taking into account a ms-timestamp, which is updated for every decision change):
library(shiny)
library(dplyr)
library(RSQLite)
# global data-frame
df <- data.frame(id = letters[1:10], decision = 0, last_mod=as.numeric(Sys.time())*1000, another_col = LETTERS[1:10])
con <- dbConnect(RSQLite::SQLite(), "my.db", overwrite = FALSE)
if (!"df" %in% dbListTables(con)) {
dbWriteTable(con, "df", df)
}
# drop global data-frame
rm("df")
update_decision_value <- function (id, dec) {
dbExecute(con, sprintf("UPDATE df SET decision = '%s', last_mod = '%s' WHERE id = '%s';", dec, as.numeric(Sys.time())*1000, id))
}
ui <- fluidPage(textOutput("shiny_session"),
uiOutput('select_id'),
uiOutput('decision_value'),
dataTableOutput('my_table'))
server <- function(input, output, session) {
output$shiny_session <- renderText(paste("Shiny session:", session$token))
session$onSessionEnded(function() {
if (!is.null(con)) {
dbDisconnect(con)
con <<- NULL # avoid warning; sqlite uses single connection for multiple shiny sessions
}
})
df_session <- dbReadTable(con, "df")
all_ids <- df_session$id
last_known_mod <- max(df_session$last_mod)
df <- reactivePoll(
intervalMillis = 100,
session,
checkFunc = function() {
req(con)
df_changed_rows <- dbGetQuery(con, sprintf("SELECT * FROM df WHERE last_mod > '%s';", last_known_mod))
if(!nrow(df_changed_rows) > 0){
return(TRUE)
}
else{
changed_ind <- match(df_changed_rows$id, df_session$id)
df_session[changed_ind, ] <<- df_changed_rows
last_known_mod <<- max(df_session$last_mod)
return(FALSE)
}
},
valueFunc = function() {
return(df_session)
}
)
filter.data <- reactive({
df() %>%
filter(decision == 0)
})
output$select_id <- renderUI({
selectInput('selected_id', "ID:", choices = all_ids)
})
output$decision_value <- renderUI({
radioButtons(
'decision_value',
"Decision Value:",
choices = c("Display" = 0, "Hide" = 1),
selected = df()[df()$id == input$selected_id, "decision"]
)
})
output$my_table <- renderDataTable({
filter.data()
})
observeEvent(input$decision_value, {
update_decision_value(input$selected_id, input$decision_value)
})
}
shinyApp(ui, server)
I am trying to get input choices dependent on previous input.
require(shiny)
require(dplyr)
dat <- data.frame(id1 = c(rep("A",5),rep("B",5)),
id2 = c(rep("C",3),rep("D",3),rep("E",4)),
id3 = c(rep("F",2),rep("G",3),rep("H",5)), stringsAsFactors=FALSE)
ui <- shinyUI(fluidPage(
sidebarPanel(
selectInput('id1', 'ID1', choices = unique(dat$id1)),
selectInput("id2", "ID2", choices = unique(dat$id2)),
selectInput("id3", "ID3", choices = unique(dat$id3))
)
)
)
server <- function(input, output,session) {
observeEvent(
{
input$id1
},{
input$id2
temp <- dat %>% filter(id1%in%input$id1)
updateSelectInput(session,"id2",choices = unique(temp$id2))
}
)
}
shinyApp(ui = ui, server = server)
This works for Input 1 and 2, however if i add another Input to observeEvent, the app chrashes. E.g:
server <- function(input, output,session) {
observeEvent(
{
input$id1
},{
input$id2
temp <- dat %>% filter(id1%in%input$id1)
updateSelectInput(session,"id2",choices = unique(temp$id2))
},{
input$id3
temp <- dat %>% filter(id1%in%input$id1 & id2%in%input$id2)
updateSelectInput(session,"id3",choices = unique(temp$id3))
}
)
}
How can I pass further Inputs to observeEvent ?
Update: I found a solution for the problem. I wrapped the Inputs in a reactive function, split the Output and passed it to the corresponding observeEvent functions.
server <- function(input, output,session) {
change <- reactive({
unlist(strsplit(paste(c(input$id1,input$id2,input$id3),collapse="|"),"|",fixed=TRUE))
})
observeEvent(input$id1,{
temp <- dat %>% filter(id1 %in% change()[1])
updateSelectInput(session,"id2",choices = unique(temp$id2))
}
)
observeEvent(input$id2,{
temp <- dat %>% filter(id1 %in% change()[1] & id2 %in% change()[2])
updateSelectInput(session,"id3",choices = unique(temp$id3))
}
)
}
Below a simplified version of my shiny app. I looked through some of the examples in the shinyjs package and I did not find anything that could help me.
I want to disable the Submit button if one of the data frame uploaded (in my real example) or selected has a specific column name (Col 3 in the example below).
Can this be done with shinyjs?
library(rhandsontable)
library(shiny)
library(shinyjs)
df1 <- data.frame(col1 = rnorm(20),
col2 = rep(T, 20))
df2 <- data.frame(col1 = rnorm(20),
col2 = rep(F, 20),
col3 = rnorm(20))
server <- function(input, output) {
values = reactiveValues()
values[["df1"]] <- df1
values[["df2"]] <- df2
df <- reactive({
if (input$df == "df1") {
df <- values[["df1"]]
} else {
df <- values[["df2"]]
}
df
})
observeEvent(input$Submit, {
shinyjs::alert("Thank you!")
})
#observe({
# if (is.null(input$df) || input$df == "df1") {
# shinyjs::disable("submit")
#} else {
# shinyjs::enable("submit")
#}
#})
output$out <- renderRHandsontable({
hot <- rhandsontable(df())
hot
})
}
ui <- fluidPage(
shinyjs::useShinyjs(),
sidebarLayout(sidebarPanel(
selectInput(
'df', 'Select data.frame:',
choices = c('df1', 'df2'),
selected = 'df1'
),
actionButton("Submit", label = "Submit")
),
mainPanel(rHandsontableOutput("out"))))
shinyApp(ui = ui, server = server)
First, there is a small typo: Notice the capital "S".
shinyjs::disable("Submit")
Edit: To check for "col3" take the following code:
observe({
if (is.null(input$df) || sum(colnames(df()) == "col3")) {
shinyjs::disable("Submit")
}else{
shinyjs::enable("Submit")
}
})
Same for enable of course.