I have a group of variables that are used as id's on html elements with matching functions (conveniently named varname.helper()) that I would like to be called whenever an event is triggered on the respective html element.
I tried the following:
server <- function(input, output, session) {
observables <- c("foo1", "foo2", "foo3") # they are obviously much more than 3 vars...
observables %>% walk(function(x) {
observeEvent(quo(!!sym(paste0("input$", x))), quo(!!sym(paste0(x, ".helper"))(input)), handler.quoted=TRUE)
}
But it didn't work. Any ideas?
Your problem starts here. Tidy evaluation is not the optimal way to solve this.
observeEvent(quo(!!sym(paste0("input$", x))),
quo(!!sym(paste0(x, ".helper"))(input)), handler.quoted=TRUE)
You want (right?) to get input$foo1 and foo1.helper. With your code, the end result is this cluster of quos, syms and exclamation marks.
First of all, if all your helper variables are doing the same thing, why do you create lots of separate variables called foo1.helper? It would make more sense to put them in a list, so you can use any kind of looping/mapping to make life easier for you:
helpers <- list(foo1 = whatever..., foo2 = whatever...)
Next,
quo(!!sym(paste0("input$", x)))
gives you a rather complex object with a specific use case. Rather than using $, you better use the double bracket selection:
input[[x]]
This lets you select an item from a list based on its name, using a character variable x. These are easier to work with. The $ syntax is just sugar and doesn't let you use character values easily.
To sum up:
observeEvent(input[[x]], quote(helpers[[x]](input)), handler.quoted = TRUE)
Here's a short example on how to fit these things in your code. Note that you have to use purrr::walk here, as you can't use a for loop. A for loop doesn't work well together with the specific way observers etc are registered by the internals of shiny.
So your code would become:
library(shiny)
library(purrr)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
actionButton("foo1", "Foo 1"),
actionButton("foo2", "Foo 2")
),
"Nothing here"
)
)
server <- function(input, output) {
helpers <- list(foo1 = quote(cat("foo 1; ")), foo2 = quote(cat("foo 2; ")))
purrr::walk(c("foo1", "foo2"), ~ observeEvent(input[[.x]],
helpers[[.x]], handler.quoted = TRUE))
}
shinyApp(ui = ui, server = server)
Related
The bounty expires in 5 days. Answers to this question are eligible for a +50 reputation bounty.
mat wants to draw more attention to this question.
I'm trying to generalize the Hierarchical select boxes approach described in the Mastering Shiny book to enable non-sequential filtering. Currently, the drill-down approach only works if the user selects categories in a specific order, for example, Terriority -> Customer -> Order number. However, I would like the drill-down to work regardless of the initial input the user provides. Additionally, my application involves approximately 10 inputs, so I want the code to be scalable.
I have been following the example in the Mastering Shiny book, but I'm having difficulty adapting the code to allow for non-sequential filtering. Specifically, when I try to modify the code to accommodate non-sequential filtering, the select boxes become unresponsive.
Any suggestions for how to modify the code to allow for non-sequential filtering would be greatly appreciated.
One way to do this is to modify and filter the underlying data. So, create a nested list of all possible combinations of the filter values, and then use the reduce() function from the purrr package to apply the filtering iteratively.
Example:
Let's say I want to filter my nutritional supplement sales. Assume we have a dataframe, df, with columns Supplement, Customer, and OrderNumber.
library(shiny)
library(purrr)
# Create a nested list of all possible filter combinations
filters <- list(
by_Supplement = split(df, df$Supplement),
by_customer = map(filters$by_Supplement, ~split(.x, .x$Customer)),
by_order_number = map(filters$by_customer, ~map(.x, ~split(.x, .x$OrderNumber)))
)
# Define a function to filter the data by a list of filter values
filter_data <- function(data, filters) {
reduce(filters, function(data, filter) {
if (!is.null(filter)) {
data %>% filter(!!!filter)
} else {
data
}
}, .init = data)
}
# Define the Shiny app UI
ui <- fluidPage(
selectInput("Supplement", "Supplement", choices = names(filters$by_Supplement)),
uiOutput("customer"),
uiOutput("order_number"),
tableOutput("table")
)
# Define the Shiny app server
server <- function(input, output, session) {
output$customer <- renderUI({
Supplement_data <- filters$by_Supplement[[input$Supplement]]
selectInput("customer", "Customer", choices = c("", names(Supplement_data)))
})
output$order_number <- renderUI({
Supplement_data <- filters$by_Supplement[[input$Supplement]]
if (!is.null(input$customer)) {
customer_data <- Supplement_data[[input$customer]]
selectInput("order_number", "Order Number", choices = c("", customer_data$OrderNumber))
} else {
selectInput("order_number", "Order Number", choices = "")
}
})
output$table <- renderTable({
filter_values <- list(Supplement = input$Supplement, Customer = input$customer, OrderNumber = input$order_number)
filtered_data <- filter_data(df, map(filters, ~if (!is.null(.x)) .x[[filter_values[[names(.x)]]]]))
filtered_data
})
}
# Run the Shiny app
shinyApp(ui, server)
filter_data() goes into output$table with a list of filter values, via map() and has the currently selected values of all three select boxes, regardless of the order of selection.
I generate a dynamic number of valueBox in my shiny, and this number can change depending of the user input.
I managed to handle this with a renderUI where I put the wanted number of valueBoxOutput, and I have an observe that will feed them with the content using renderValueBox.
My problem is: the code in the renderValueBox, for some reason, is actually executed after the observe is finished, so because the renderValueBox is in a loop (to have a dynamic number of them) but the code is executed for all the output after the loop, all my output will get the last value of the loop.
Here is a min reprex:
library(shiny)
library(shinydashboard)
library(shinyWidgets)
# Function
compute <- function(id)
{
print(paste("Compute ", id))
return(id)
}
# UI
ui = shinyUI(fluidPage(
titlePanel("Compare"),
useShinydashboard(),
sidebarLayout(
sidebarPanel(
numericInput("numitems", label = "Number of items", min = 1, max = 10, value = 2)
),
mainPanel(
uiOutput("boxes")
)
)
))
# Server
server = shinyServer(function(input, output, session) {
data <- reactiveValues(
ids = list()
)
output$boxes <- renderUI({
print("boxes")
box_list <- list()
id_list <- list()
for(id in 1:(input$numitems)) {
id_box <- paste0("box_", id)
print(paste("boxes - ", id_box))
id_list <- append(id_list, id_box)
box_list <- append(
box_list,
tagList(
shinydashboard::valueBoxOutput(id_box)
)
)
data$ids <- id_list
}
print("boxes end")
fluidRow(box_list)
})
observe({
print("observe")
for(id_box in data$ids) {
print(paste("observe - ", id_box))
output[[id_box]] <- shinydashboard::renderValueBox(valueBox(id_box, compute(id_box), icon = icon("circle-info"), color = "teal"))
}
print("end observe")
})
})
# Run
shinyApp(ui = ui , server = server)
Here is the result:
And the console output:
As you can see the compute (and the render in general) is done after the end of the observe function, and both output will use the last id_box that were set (so the last loop, box_2), instead of correctly using box_1 and box_2.
I tried using force, computing valueBox outside the render, using reactive lists, nothing worked, because whatever I do the render is evaluated after the observe so only the last loop values will be used no matter what.
Do anyone know a way to force execution during the loop ? Or see another way of achieving the same result ?
Why it's always after spending hald a day on a problem, looking for dozens of posts and forum, don't find anything, finally decide to ask a question... that a few minutes later I finally find an answer.
Anyway, one way to correct this (found here) is to encapsulate the render inside the local function, like this:
observe({
print("observe")
for(id_box in data$ids) {
print(paste("observe - ", id_box))
local({
tmp <- id_box
output[[tmp]] <- shinydashboard::renderValueBox(valueBox(tmp, compute(tmp), icon = icon("circle-info"), color = "teal"))
})
}
print("end observe")
})
Now the compute is still called after the end of the observe, but the tmp variable has the correct value:
The result is what I wanted:
For the record, I had already tried to use the local function, but if you don't copy the id_box inside another variable just for the local bloc, it won't work.
I am trying to write a shiny app to accommodate a specific function which estimates numbers of fish from sampled data. The function creates an amalgamated variable that is nonsense to the user. The code does run, but I am trying to modify this table after the fact to create variables that will make sense to the user. In order to do this, I need to split the nonsense variable into parts, rename those parts, and specify which ones to print. I can do this in the tidyverse using mutate, but haven't figured out how or where to incorporate these changes so that it doesn't kill the app.
I have tried a reactive within server. I have tried to perform these changes within renderTable.
In the code below, estimate is the output of the custom function MRIP.catch and the output needs to be modified. There is an output column called "domain" that conglomerates all of the inputs. I need to split these back apart so that the user knows what they are looking at in the table output.
I know this code isn't run-able on it's own. I was just hoping that it was a simple syntax question that someone could help me to untangle. I haven't been able to find examples of tables that need to be changed after being calculated but before being displayed.
server <- function(input, output, session) {
sp<-eventReactive(input$go,{input$species})
yr1<-eventReactive(input$go, {input$start_yr})
yr2<-eventReactive(input$go, {input$end_yr})
freq2<-eventReactive(input$go,{
case_when(input$freq =='annual'~annual,
input$freq =='wave'~wave)
})
sub<-eventReactive(input$go, {
case_when(input$reg =='by state'~state,
input$reg =='by coast'~coast)
})
mode<-eventReactive(input$go, {
case_when(input$modes=='all modes combined'~all_mode,
input$modes=='all modes by mode'~each_mode)
})
area<-eventReactive(input$go, {
case_when(input$areas == 'all areas combined'~all_area,
input$areas=='all areas by area'~each_area)
})
dom1<- eventReactive(input$go, {list(wave=freq2()#Use for annual estimate. Comment out for wave
,sub_reg=sub() #Use for custom geo regions
,mode_fx=mode() #use to combine modes.
,area_x=area() #Use to combine fishing areas.
)})
estimate<-eventReactive(input$go,{
MRIP.catch(intdir='C:\\Users\\',
st = 12, styr = yr1(), endyr= yr2(), common = sp()
, dom = dom1()
)})
output$species <- renderText({paste( 'you have seletected',sp()) })
output$range<-renderText({paste ('from',yr1(), 'to', yr2())})
output$table<-renderTable({estimate()})
}
The following is the code I used in dplyr to create the independent sections of the variable and rename them. I'm sure it isn't the most elegant way to make this go, but it does work.
##Separates out each piece of domain to name
estimate<-
estimate%>%
mutate (yr = substr(Domain, 5,8),
wave1=substr(Domain,13,13),
basin1=substr(Domain,25,25),
mode1=substr(Domain, 33,33),
area1=substr(Domain, 40,40),
cntys1=substr(Domain, 45,45),
yr_wave=paste(yr,wave1, sep='-'))
estimate<-
estimate%>%
mutate (basin = case_when (basin1 == '6' ~'SA',
basin1=='7'~'Gulf',
basin1=='1'~'statewide'
),
mode = case_when(mode1=='1'~'combined',
mode1 =='3'~'Shore',
mode1=='5'~'Charter',
mode1=='7'~'Private'),
area = case_when(area1 =='1'~'EC state',
area1=='2'~'EC fed',
area1=='3'~'Gulf state',
area1=='4'~'Gulf fed',
area1=='5'~'Inland'))
I will try to focus on this part: "find examples of tables that need to be changed after being calculated but before being displayed".
Take a look at the example below and check if this is something which can help you.
library(shiny)
ui <- fluidPage(
actionButton("go", "Go"),
tableOutput("table")
)
server <- function(input, output, session) {
df <- reactiveVal(data.frame(a = c(1, 2))) # but reactiveVal() can be left empty as well, then it starts with NULL value
initial_data <- reactive({
first_computation <- df() %>%
mutate(b = c(3, 4))
df(first_computation )
})
observeEvent(input$go, {
second_computation <- initial_data() %>%
mutate(c = c(5, 6))
df(second_computation)
})
output$table <- renderTable({
req(input$go) # not sure if this will be enough for your needs!
df()
})
}
shinyApp(ui, server)
I created reactiveVal object and this is most important part - this object can be use in different places (active-reactive context) and can be modify. At first is data.frame with one variable, then I made some computation, but do not display anything. Then I have made some new additional computation when user clicks "go" and after that the new table is displayed.
I am new to Shiny. I was trying to subset a data frame and the data frame, but encountered an error message:
"Can't access reactive value 'xx' outside of reactive consumer."
Could anybody tell me why?
The design idea is to (1) let the users to select the subgroup that they'd like to look into, which I tried to accomplish using the reactiveValues() command but failed, and then (2), an delayed action, which is within that subgroup, sort the data based on a key variable. Below are the codes, and I appreciate your help:
library(shiny)
library(tidyverse)
data(iris)
ui <- fluidPage(
navbarPage(
title = "Test",
tabsetPanel(
tabPanel(
"Tab 3, subset and then sort",
sidebarLayout(
sidebarPanel(
selectInput("xx", "species:", choices = unique(iris$Species), selected = "setosa"),
actionButton("click", "sort")
),
mainPanel(
tableOutput("table3")
)
)
)
)
)
)
server <- function(input, output) {
rv <- reactiveValues(
#### This line caused a problem whenever I added %>% dplyr::filter ####
df3 = iris %>% dplyr::filter(Species == !!input$xx)
)
observeEvent(input$click, {
rv$df3 <- rv$df3[order(rv$df3$Sepal.Length), ]
})
output$table3 <- renderTable({
rv$df3
})
}
# Run the application
app <- shinyApp(ui = ui, server = server)
runApp(app)
reactiveValues should be used like a list of values that are updated/evaluated within reactive/observe blocks. It's being used incorrectly here, I think you should be using reactive or eventReactive.
Double-bang !! is relevant for NSE (non-standard evaluation) within rlang (and much of the tidyverse), but that's not what you're doing here. In your case, input$xx is character, in which case you can simply compare to it directly, ala Species == input$xx.
Sometimes, depending on the startup of an app, the reactive is triggered before the input has a valid value, instead it'll be NULL. This causes an error and glitches in the shiny interface, and can be avoided by the use if req.
Unfortunately, you can't resort a reactive data block outside of it.
Here's one alternative:
server <- function(input, output) {
rv_unsorted <- reactive({
req(input$xx)
dplyr::filter(iris, Species == input$xx)
})
rv_sorted <- reactive({
req(input$click)
dplyr::arrange(isolate(rv_unsorted()), Sepal.Length)
})
output$table3 <- renderTable({
rv_sorted()
})
}
Another method, which is less efficient (more greedy, less lazy),
server <- function(input, output) {
rv <- reactiveVal(iris)
observeEvent(input$xx, {
rv( dplyr::filter(iris, Species == input$xx) )
})
observeEvent(input$click, {
rv( dplyr::arrange(rv(), Sepal.Length) )
})
output$table3 <- renderTable({
rv()
})
}
This may seem more straight-forward logically, but it will do more work than will technically be necessary. (observe blocks are greedy, firing as quickly as possible, even if their work is not used/noticed. reactive blocks are lazy in that they will never fire unless something uses/needs them.)
Edit: I corrected the previous behavior, which was:
Load iris, have all species present, store in rv().
Immediately filter, showing just setosa, store in rv().
Display in the table.
Change selector to a new species.
Filter the contents of rv() so that only the new species are in the frame. Unfortunately, since the contents of rv() were just setosa, this next filtering removed all rows.
The means that the current observe-sequence (as greedy and inefficient as it may be) must start with a fresh frame at some point, so I changed the input$xx observe block to always start from iris.
So, I've been on google for hours with no answer.
I want to create a user-defined function inside the server side that takes inputs that I already know to wrap reactive({input$feature)} but the issue is how to incorporate reactive values as inputs too.
The reason why I want to do this is because I have a navbarPage with multiple tabs that shares elements such as same plots. So I want a user defined function that creates all the similar filtering and not have to create multiple of the same reactive expression with different input and reactive variable names which take up 2000+ lines of code.
server <- function(input, output) {
filtered_JointKSA <- reactiveVal(0)
create_filtered_data <- function(df, input_specialtya, filtered_JointKSA) {
if (input_specialtya == 'manual') {
data <- filter(data, SPECIALTY %in% input_specialtyb)
}
if (filtered_JointKSA != 0) {
data <- filter(data, SPECIALTY %in% filtered_JointKSA)
}
reactive({return(data)})
}
filtered_data <- create_filtered_data(df,
reactive({input$specialty1}),
filtered_JointKSA())
observeEvent(
eventExpr = input$clickJointKSA,
handlerExpr = {
A <- filtered_JointKSA(levels(fct_drop(filtered_data()$`Joint KSA Grouping`))[round(input$clickJointKSA$y)])
A
}
)
This gets me an error:
"Error in match(x, table, nomatch = 0L) :
'match' requires vector arguments"
The error is gone if I comment out where I try to create filtered_data but none of my plots are created because filtered_data() is not found.
What is the correct approach for this?
Ideally, I would like my observeEvents to be inside user defined functions as well if that has a different method.
This example may provide some help, but it's hard to tell without a working example. The change is to wrap the call to your function in reactive({}) rather than the inputs to that function, so that the inputs are all responsive to user input and the function will update.
library(shiny)
ui <- fluidPage(
numericInput("num", "Number", value = NULL),
verbatimTextOutput("out")
)
server <- function(input, output){
## User-defined function, taking a reactive input
rvals <- function(x){
req(input$num)
if(x > 5){x * 10} else {x*1}
}
# Call to the function, wrapped in a reactive
n <- reactive({ rvals(input$num) })
# Using output of the function, which is reactive and needs to be resolved with '()'
output$out <- renderText({ n() })
}
shinyApp(ui, server)