eventReactive recalculates already calculated objects with unchanged input - r

As I understand, eventReactive (or any reactive function) should not recalculate stuff whose related input did not change, but this is what's happening in my case. I'm pretty sure I'm doing something wrong but I just don't know what. In essence, I have two eventReactive functions, one involves a very time-consuming calculation, and the other mainly just plotting (should be quite quick). However, even when I change some inputs for plotting, the first eventReactive function is executed too (even though it's not needed).
Here is a shortened version of my code:
server <- function(input, output) {
res_tabl <-
eventReactive(c(input$recalc, input$recalc2), # this is a time-consuming calculation
ignoreNULL = FALSE, {
prep_sim(
gg_start = input$gg_start,
gg_end = input$gg_end
)
})
threeplots <-
eventReactive(c(input$recalc, input$recalc2), # this is for plotting
ignoreNULL = FALSE, {
prep_plot(
results_to_plot = res_tabl(),
yval_opt = input$yval_opt
)
})
output$esdc_plot_comb <- renderPlot({
threeplots()[[1]]
})
output$esdc_plot_tot <- renderPlotly({
threeplots()[[2]]
})
output$esdc_plot_comb2 <- renderPlot({
threeplots()[[1]]
})
output$esdc_plot_tot2 <- renderPlotly({
threeplots()[[2]]
})
output$esdc_table <- renderDataTable({
res_tabl()
})
}
What should I do so that when I press a single Action button and I only changed input$yval_opt, only the second eventReactive content would run? (Nothing should run until I click the button.)
Less importantly – and perhaps this should be a separate question – as you can see I render each of the two returned plots twice. Is there perhaps a more efficient way to do this?
(The full code is available here.)

This was tricky.
To avoid automatic calculation at App start-up, you should set ignoreNULL = T
This works on a single condition, but not on multiple conditions using c(recalc1,recalc2)
Solution is :
eventReactive(req(isTruthy(input$recalc1) | isTruthy(input$recalc2)), ignoreNULL = T,...
Added a reactiveVal() to keep track of last calculation update
I think following Minimal Reproducible example responds to your needs :
library(shiny)
# Define UI
ui <- fluidPage(
# Application title
titlePanel("Test"),
# Sidebar with a slider inpust
sidebarLayout(
sidebarPanel(
sliderInput("vizslider",
"viz percentage:",
min = 1,
max = 100,
value = 30),
sliderInput("calcslider",
"Calculation duration (s):",
min = 1,
max = 10,
value = 2),
actionButton("recalc1", "Calc 1"),
actionButton("recalc2", "Calc 2"),
),
# Show result
mainPanel(
textOutput("result")
)
)
)
# Define server logic
server <- function(input, output) {
lastcalc <- reactiveVal(0)
run <- reactive({})
calcresult <- eventReactive(req(isTruthy(input$recalc1) | isTruthy(input$recalc2)), ignoreNULL = T, {
if (lastcalc()==input$calcslider) {return("last calculation")} else {lastcalc(input$calcslider)}
cat("Start calc for ",input$calcslider, "seconds\n")
Sys.sleep(input$calcslider)
cat("End calc \n")
paste("calculation done in",input$calcslider,"seconds")
})
output$result <- eventReactive(c(input$recalc1,input$recalc2), ignoreNULL = T, {
req(calcresult())
paste("filter",input$vizslider,"% of a ",calcresult())
})
}
# Run the application
shinyApp(ui = ui, server = server)

Related

Issue with R shiny's DT::dataTableOutput() forcing unnecessary reactivity updates

I'm working on an R shiny app structured like this:
library(shiny)
library(DT)
# global function
make_data = function(input){
data.frame(x = input$x, `x_times_2` = input$x*2)
}
ui <- fluidPage(
sliderInput("x", label = "Set x:", min = 1, value = 7, max = 10),
# Recalculates continuously, bad!
dataTableOutput("dtab"),
# Recalculates when inputs change, good!
# tableOutput("tab")
)
server <- function(input, output, session) {
reactive_data = reactive({
print("Recalculating Data")
make_data(reactiveValuesToList(input))
})
output$tab = renderTable({
reactive_data()
})
output$dtab = renderDataTable({
reactive_data()
})
}
shinyApp(ui, server)
My problem is that dataTableOutput("dtab") forces continuous recalculation of reactive_data whereas tableOutput("tab") (correctly) only recalculates when inputs change. Can someone help me understand why this happens?
I need to be able to pass inputs into a global function that makes a data frame which I then need to display. I want to use dataTableOutput() for the customization that DT offers but need it to only recalculate when any input is changed.
In this situation, you could use eventReactive() instead of reactive. Try this
reactive_data = eventReactive(input$x, {
print("Recalculating Data")
make_data(reactiveValuesToList(input))
})

How to ask R Shiny to create several "select boxes" - based on previous input

In my tiny Shiny app I am asking the user: how many time periods do you want to cut your time series into? For example, the user selects 3.
I want to use this input to take a fixed vector of dates and make it possible for the user the select from it the desired last date of Time Period 1 (in select box 1), and Time Period 2 (in select box 2). (The last date for time period 3 will be the very last date, so I don't need to ask).
I am not sure how to do it. I understand that because I don't know the desired number of time periods in advance, I have to create a list. But how do I then collect the input from those select boxes?
Thanks a lot!
library(shiny)
### UI #######################################################################
ui = shinyUI(fluidPage(
titlePanel("Defining time periods"),
# Sidebar:
sidebarLayout(
sidebarPanel(
# Slider input for the number of time periods:
numericInput("num_periodsnr", label = "Desired number of time periods?",
min = 1, max = 10, value = 2),
uiOutput("period_cutpoints")
),
# Show just the number of periods so far.
mainPanel(
textOutput("nr_of_periods")
)
)
))
### SERVER ##################################################################
server = shinyServer(function(input, output, session) {
library(lubridate)
output$nr_of_periods <- renderPrint(input$num_periodsnr)
# Define our dates vector:
dates <- seq(ymd('2016-01-02'), ymd('2017-12-31'), by = '1 week')
# STUCK HERE:
# output$period_cutpoints<-renderUI({
# list.out <- list()
# for (i in 1:input$num_periodsnr) {
# list.out[[i]] <- renderPrint(paste0("Sometext", i), ,
# )
# }
# return(list.out)
# })
})
# Run the application
shinyApp(ui = ui, server = server)
This is similar to a question I asked and subsequently worked out an answer to here. The big changes are (predictably) in the server.
Nothing needs to change in the UI, but as you'll see below I've included another textOutput so that you can see the dates you end up selecting, and I've also added an actionButton, which I'll explain later.
The server function has a couple additions, which I'll describe first and then put together at the end. You're right that you need to create a list of input objects inside the renderUI, which you can do through lapply. At this step, you're creating as many selectInputs as you'll have cutpoints, minus one because you say you don't need the last:
output$period_cutpoints<-renderUI({
req(input$num_periodsnr)
lapply(1:(input$num_periodsnr-1), function(i) {
selectInput(inputId=paste0("cutpoint",i),
label=paste0("Select cutpoint for Time Period ", i, ":"),
choices=dates)
})
})
Next, you'll need to access the values selected in each, which you can do in the same way, using a reactiveValues object you create first, and assign the new values to it. In my version of this problem, I couldn't figure out how to get the list to update without using an actionButton to trigger it. Simple reactive() or observe() doesn't do the trick, but I don't really know why.
seldates <- reactiveValues(x=NULL)
observeEvent(input$submit, {
seldates$x <- list()
lapply(1:(input$num_periodsnr-1), function(i) {
seldates$x[[i]] <- input[[paste0("cutpoint", i)]]
})
})
Full working app code then looks like this:
library(shiny)
ui = shinyUI(fluidPage(
titlePanel("Defining time periods"),
sidebarLayout(
sidebarPanel(
numericInput("num_periodsnr", label = "Desired number of time periods?",
min = 1, max = 10, value = 2),
uiOutput("period_cutpoints"),
actionButton("submit", "Submit")
),
mainPanel(
textOutput("nr_of_periods"),
textOutput("cutpoints")
)
)
))
server = shinyServer(function(input, output, session) {
library(lubridate)
output$nr_of_periods <- renderPrint(input$num_periodsnr)
dates <- seq(ymd('2016-01-02'), ymd('2017-12-31'), by = '1 week')
output$period_cutpoints<-renderUI({
req(input$num_periodsnr)
lapply(1:(input$num_periodsnr-1), function(i) {
selectInput(inputId=paste0("cutpoint",i),
label=paste0("Select cutpoint for Time Period ", i, ":"),
choices=dates)
})
})
seldates <- reactiveValues(x=NULL)
observeEvent(input$submit, {
seldates$x <- list()
lapply(1:(input$num_periodsnr-1), function(i) {
seldates$x[[i]] <- input[[paste0("cutpoint", i)]]
})
})
output$cutpoints <- renderText({as.character(seldates$x)})
})
shinyApp(ui = ui, server = server)
you can make the boxes dynamically inside an lapply and send them as 1 output object to the ui
require("shiny")
require('shinyWidgets')
ui = shinyUI(fluidPage(
titlePanel("Defining time periods"),
# Sidebar:
sidebarLayout(
sidebarPanel(
# Slider input for the number of time periods:
numericInput("num_periodsnr", label = "Desired number of time periods?",
min = 1, max = 10, value = 2),
uiOutput("period_cutpoints")
),
# Show just the number of periods so far.
mainPanel(
textOutput("nr_of_periods")
)
)
))
# Define server logic ----
server <- function(session, input, output) {
output$period_cutpoints<- renderUI({
req(input$num_periodsnr > 0)
lapply(1:input$num_periodsnr, function(el) {
airDatepickerInput(inputId = paste('PeriodEnd', el, sep = ''), label = paste('Period End', el, sep = ' '), clearButton = TRUE, range = F, update_on = 'close')
})
})
}
# Run the app ----
shinyApp(ui = ui, server = server)
Since you did not provide a dataset to apply the inputs on, and I don't know what date ranges your data has, I did not add code to set min/max on the date pickers, and not sure what kind of code to provide for you to use the data. You would need to write something to put them in a list indeed
values <- reactiveValues(datesplits = list(),
previous_max = 0)
observeEvent(input$num_periodsnr, {
if(input$num_periodsnr > values$previous_max) {
lapply(values$previous_max:input$num_periodsnr, function(el) {
observeEvent(input[[paste(paste('PeriodEnd', el, sep = '')]], {
values$datesplits[el] <- input[[paste(paste('PeriodEnd', el, sep = '')]]
})
values$previous_max <- max(values$previous_max, input$num_periodsnr)
})
}
})
and then use the list of dates for whatever you need to do with them I think.
I use the trick with run lapenter code hereply from previous_max to input$num_periodsnr if(input$num_periodsnr > values$previous_max){} to avoid the problem you create when you repeatedly create observers for the same input element. Whereas ui elements are overwritten when created in a loop, observeEvents are made as copies, so every time your loop fires, you make another copy of observers 1:n. This results in all copies firing every time, until you have a million observers all firing, creating possible strange bugs, unwanted effects and loss of speed.

implement a simple counter to count reactive firing in Shiny

I would like to keep track of how many times the user has refreshed my Shiny vis.
I figured I would just set a counter up outside of the reactive area
number <- 0
and have it update by adding one every time the code in reactive block fires.
But it doesn't work.
Ideas:
make the counter a global var?
silly idea, doesn't work
put the number <- 0 inside the reactive area?
of
course that's not the solution
I'm not sure which direction to go here. Anyone have any ideas?
require(shiny)
number <- 0
runApp(list(ui = pageWithSidebar(
headerPanel("This is a test"),
sidebarPanel(
helpText("This is a test"),
sliderInput("range",
label = "Pick a number:",
min = 0, max = 100, value = 0)
),
mainPanel(textOutput("text1"),
htmlOutput("text")
)
),
server = function(input, output) {
number <- number + 1
output$text <- renderUI({
str <- paste("You have chosen:",
input$range)
HTML(paste(str, sep = '<br/>'))
View(number)
})
}
)
)
Shiny has reactiveValues that are like an environment - they get passed by reference so you can assign to them with the regular assignment operator from within reactive expressions. For example,
library(shiny)
ui <- pageWithSidebar(
headerPanel("This is a test"),
sidebarPanel(sliderInput("range", "Pick", 0, 100, 10)),
mainPanel(htmlOutput("text"))
)
server <- function(session, input, output) {
vals <- reactiveValues(count = -1)
observeEvent(input$range, vals$count <- vals$count + 1)
output$text <- renderUI({
HTML(paste(sprintf("You have chosen: %s</br>", vals$count)))
})
}
shinyApp(ui, server)
Sidenote: you could also do it as a global variable like mentioned using <<-, but I would say it is a bad idea because of how <<- searches backwards through environments, and I think that it could have surprising results.

R shiny isolate reactive data.frame

I am struggling to understand how isolate() and reactive() should be used in R Shiny.
I want to achieve the following:
Whenever the "Refresh" action button is clicked:
Perform a subset on a data.frame and,
Feed this into my function to recalculate values.
The subset depends on a group of checkboxes that the user has ticked, of which there are approximately 40. I cannot have these checkboxes "fully reactive" because the function takes about 1.5 sec to execute. Instead, I want to give the user a chance to select multiple boxes and only afterwards click a button to (a) subset and (b) call the function again.
To do so, I load the data.frame in the server.R function:
df1 <- readRDS("D:/././df1.RData")
Then I have my main shinyServer function:
shinyServer(function(input, output) {
data_output <- reactive({
df1 <- df1[,df1$Students %in% input$students_selected]
#Here I want to isolate the "students_selected" so that this is only
#executed once the button is clicked
})
output$SAT <- renderTable({
myFunction(df1)
})
}
How about something like
data_output <- eventReactive(input$button, {
df1[,df1$Students %in% input$students_selected]
})
Here is my minimal example.
library(shiny)
ui <- list(sliderInput("num", "rowUpto", min= 1, max = 10, value = 5),
actionButton("btn", "update"),
tableOutput("tbl"))
server <- function(input, output) {
data_output <- eventReactive(input$btn, {
data.frame(id = 1:10, x = 11:20)[seq(input$num), ]
})
output$tbl <- renderTable({
data_output()})
}
runApp(list(ui = ui, server = server))
Edit
Another implementation, a bit more concise.
renderTable by default inspects the changes in all reactive elements within the function (in this case, input$num and input$button).
But, you want it to react only to the button. Hence you need to put the elements to be ignored within the isolate function.
If you omit the isolate function, then the table is updated as soon as the slider is moved.
library(shiny)
ui <- list(sliderInput("num", "rowUpto", min= 1, max = 10, value = 5),
actionButton("btn", "update"),
tableOutput("tbl"))
server <- function(input, output) {
output$tbl <- renderTable({
input$btn
data.frame(id = 1:10, x = 11:20)[seq(isolate(input$num)), ]
})
}
runApp(list(ui = ui, server = server))
Use eventReactive instead:
data_output <- eventReactive(input$updateButton, {
df1 <- df1[,df1$Students %in% input$students_selected] #I think your comments are messed up here, but I'll leave the filtering formatting to you
})
output$SAT <- renderTable({
data_output()
})
And in your UI you should have something like:
actionButton('updateButton',label = "Filter")
Looking at ?shiny::eventReactive:
Use eventReactive to create a calculated value that only updates in
response to an event. This is just like a normal reactive expression
except it ignores all the usual invalidations that come from its
reactive dependencies; it only invalidates in response to the given
event.

Trigger an event in shiny when a variable exceeds a threshold

I have a continuous variable (the zoom on a leaflet map) and I want to activate some action (polygon drawing) only when this variable exceeds a given threshold (only at after a given zoom level).
Here is a similar - but simpler and easier to reproduce - toy problem:
ui <- bootstrapPage(
sliderInput("slider", label='a number', min=100, max=400, value = 150),
plotOutput("plot")
)
server <- function(input, output, session) {
observeEvent(input$slider > 200, {
output$plot <- renderPlot(plot(rnorm(10000), rnorm(10000)))
})
}
shinyApp(ui, server)
The problem is that, because of Shiny's reactivity system, the plot (in the toy problem) or the map (in the real problem) keep being updated, even though I would like them to be updated only when the threshold is passed, in either direction.
I tried constructions with observeEvent, eventReactive, reactiveValues, etc. mixed with if ... else declarations. But is seems like whenever an input is updated, it triggers the whole chain of events, regardless of whether the dependent variables have changed or not. In the toy problem, it does not matter that input$slider > 200 stays TRUE when input$slider goes from 100 to 101, it triggers the plotting anyways.
Please tell me I am wrong!
Instead of using observeEvent(), you could use a regular observe() and use the condition for an if statement and simply return() if the condition fails.
Something like
observe({
if (input$slider <= 200) return()
...
})
EDIT: In the comments you wanted to somehow track the last value. Here's how you can do this.
library(shiny)
ui <- fluidPage(
sliderInput("slider", "Slider", 1, 500, 100)
)
server <- function(input, output, session) {
values <- reactiveValues(last = 0)
observe({
if (input$slider <= 200 & values$last > 200) {
cat("check!")
}
values$last <- input$slider
})
}
shinyApp(ui = ui, server = server)
So, inspired by #daattali and our discussion, one possible solution is to use a reactiveValue to store the last value of the slider in order to test when the threshold is passed in either directions. The test itself is carried inside an observe function:
ui <- bootstrapPage(
sliderInput("slider", label='a number', min=100, max=400, value = 150),
plotOutput("plot")
)
server <- function(input, output, session) {
output$plot <- renderPlot(plot(rnorm(10000), rnorm(10000)))
last <- reactiveValues(value = 0)
observe({
if ((input$slider <= 200 & last$value > 200)|(input$slider > 200 & last$value <= 200)) {
output$plot <- renderPlot(plot(rnorm(10000), rnorm(10000)))
}
last$value <- input$slider
})
}
shinyApp(ui, server)
With this solution, I correctly have an update only when the threshold (200 on the slider) is passed in either directions.

Resources