R Shiny: Use reactiveValues() with data.table assign-by-reference - r

I have a shiny app in which more than one reactive component uses the same result from a function that is slow to calculate. To avoid calculating the slow function more than once, I can use reactiveValues() to recalculate the function when its inputs change, and make the result available to all reactive components that require it.
But, if the reactiveValues object is a data.table, and I update it using :=, shiny does not detect the change, and the outputs that rely on it do not get updated.
Is there any way to use data.table assign by reference either with reactiveValues or another way that avoids recalculating the function multiple times.
Here is a reproducible example using data.table assign-by-reference in which output$result2 fails to get updated when the input changes:
library(shiny)
library(data.table)
library(plotly)
ui = fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput('x1', 'x1', min=0, max=2, value=1, step=0.1)
),
mainPanel(
plotlyOutput('result1'),
verbatimTextOutput('result2')
)
)
)
server = function(input, output) {
values <- reactiveValues()
values$dt = data.table(v1 = 1:100, v2 = 1)
slow.func = function(my.dt, x) {
Sys.sleep(2)
my.dt[, v2 := v1^x]
}
output$result1 = renderPlotly({
values$dt = slow.func(values$dt, input$x1)
plot_ly(values$dt) %>%
add_lines(x = ~v1, y = ~v2)
})
output$result2 = renderText({
paste('Final value =', values$dt[.N, v2])
})
}
shinyApp(ui = ui, server = server)
For comparison, here is a version of the server function using standard assignment of data.frames, which does perform as expected:
server = function(input, output) {
values <- reactiveValues()
values$dt = data.frame(v1 = 1:100, v2 = 1)
slow.func = function(my.dt, x) {
my.dt$v2 = my.dt$v1^x
Sys.sleep(2)
my.dt
}
output$result1 = renderPlotly({
values$dt = slow.func(values$dt, input$x1)
plot_ly(values$dt) %>%
add_lines(x = ~v1, y = ~v2)
})
output$result2 = renderText({
paste('Final value =', values$dt[100,]$v2)
})
}

say you have defined a reactive variable table_updated so you can increment it by one each time the slow function is done. Other values/plots will only need to observe table_updated.
Actually the actionButton(see description section) does the same thing, every time it gets clicked, its value is incremented by 1.
values <- reactiveValues(table_updated = 0)
slow.func = function(my.dt, x) {
# do stuff
values$table_updated <- values$table_updated + 1
}
output$result2 = renderText({
values$table_updated
paste('Final value =', values$dt[100,]$v2)
})

Related

How can I stop rhandsontable from starting an infinite loop after inputs in quick succession?

I'm using rhandsontable in a shiny app to manually update a dataframe to be displayed with ggplot2.
When adding/changing values in the rhandsontable in quick succession, the table starts an infinite loop, which immobilizes the entire shiny application.
Below an example. By quickly changing the values in the table, the app gets stuck.
library(shiny)
library(rhandsontable)
library(ggplot2)
ui <- fluidPage(
rHandsontableOutput("hot"),
plotOutput("plot")
)
server <- function(input, output, session) {
reactive.table <- reactiveValues(values = data.frame(x = c(1,2), y = c(1,2)))
observe({
if (!is.null(input$hot)) {
reactive.table$values <<- hot_to_r(input$hot)
}
})
output$hot <- renderRHandsontable({
rhandsontable(reactive.table$values)
})
output$plot <- renderPlot({
Sys.sleep(2)
ggplot(reactive.table$values, aes(x = x, y = y)) +
geom_point()
})
}
shinyApp(ui = ui, server = server)
Is there a way to stop the infinite loop or to disable further inputs until the plot is rendered?
Thanks.
I don't know how to stop rhandsontable from starting the infinite loop, but you can avoid inputs in quick succession altogether.
Taking your reprex, I restrict changes to be at least 1 second apart, and it works just fine.
library(shiny)
library(rhandsontable)
library(ggplot2)
ui <- fluidPage(
rHandsontableOutput("hot"),
plotOutput("plot")
)
server <- function(input, output, session) {
reactive.table <- reactiveValues(values = data.frame(x = c(1,2), y = c(1,2)))
rv_timer <- reactiveValues(
prev = NULL, current = NULL
)
observe({
if (!is.null(input$hot)) {
# if it's first time editing table:
if (is.null(rv_timer$prev)) {
rv_timer$prev <- Sys.time()
reactive.table$values <- hot_to_r(input$hot)
return(NULL)
}
# if it's not the first time to edit table, get current clock time:
rv_timer$current <- Sys.time()
# if the difference btwn prev recorded time and current time is less
# than 1second, don't do anything, just return:
if ((rv_timer$current - rv_timer$prev) < 1) {
return(NULL)
}
# otherwise proceed as normal:
reactive.table$values <- hot_to_r(input$hot)
# finally set current clock time as `rv_timer$prev` for use in the next
# invalidation:
rv_timer$prev <- Sys.time()
}
})
output$hot <- renderRHandsontable({
rhandsontable(reactive.table$values)
})
output$plot <- renderPlot({
Sys.sleep(2)
ggplot(reactive.table$values, aes(x = x, y = y)) +
geom_point()
})
}
shinyApp(ui = ui, server = server)
Might be a bug in {rhansontable}.

Use a function to generate reactive values in a reactiveValues object in Shiny

I have numerous reactive elements to create in a {Shiny} reactiveValues object, all requiring almost identical filtering code. But I cannot work out how to do this efficiently, i.e. without writing the filtering code directly for each element. In the sample code below, a radio button controls filtering of some data into 2 groups, A and B. The difference between the good and bad outputs is that the bad one uses a function to define its value, whereas the good one has it specified directly as a reactive object.
When using the function to create the value for the bad one, it seems to be stuck at the intial value, as when changing the data by selecting a different group it does not change. The good one does correctly filter the data however. So how could we create many elements with the same code in the reactiveValues object?
library(shiny)
ui <- fluidPage(
radioButtons(
"group", "",
list(A = "A", B = "B"), list("A"),
inline = TRUE
),
actionButton("go", "Go"),
textOutput("filtered_data_bad"),
textOutput("filtered_data_good")
)
server <- function(input, output) {
data <- tibble(
group = rep(c("A", "B"), c(5, 10))
)
group_saved <- reactiveVal(value = c("A"))
observeEvent(
input$go,
group_saved(input$group),
ignoreInit = TRUE,
ignoreNULL = FALSE
)
filter_data <- function (.data, .group) {
reactive(
.data[.data$group %in% .group,]
)
}
format_text <- function (.data, .group) {
req(nrow(.data) > 0)
paste(
"Selected:",
nrow(.data),
"total"
)
}
rv <- reactiveValues(
bad = filter_data(data, group_saved()),
good = reactive(
data[data$group %in% group_saved(),]
)
)
output$filtered_data_bad <- renderText({
format_text(rv$bad(), group_saved())
})
output$filtered_data_good <- renderText({
format_text(rv$good(), group_saved())
})
}
shinyApp(ui, server)
The code above is as simple as I could get it while showing the issue. I am working with the requirement to be able to select many different groups simultaneously from a common pool of choices (geographical regions in fact), for which the reactiveValues will hold one set of choices per group. Each group has its own reactiveVal object (saved_regions_A, saved_regions_B, ...) that serves as the filter.
regions_saved_A <- reactiveVal(value = regions)
regions_saved_B <- reactiveVal(value = NULL)
regions_saved_C <- reactiveVal(value = NULL)
...
filter_data <- function (.data, .regions) {
reactive(.data %>% filter(region %in% .regions))
}
filtered_data <- reactiveValues(
A = filter_data(data, regions_saved_A()),
B = filter_data(data, regions_saved_B()),
C = filter_data(data, regions_saved_C()),
...
)
I have tried removing the reactive call from the function and calling it with the function call for each value (it seems to be needed as I am relying on a reactiveVal for the saved choices). None of the below work:
filter_data <- function (.data, .regions) {
.data %>% filter(region %in% .regions)
}
filtered_data <- reactiveValues(
A = reactive(filter_data(data, regions_saved_A())),
B = filter_data(data, regions_saved_B()),
...
)
Assign the reactiveValues in an observer. No need to make them reactive again. Try this
library(shiny)
ui <- fluidPage(
radioButtons(
"group", "",
list(A = "A", B = "B"), list("A"),
inline = TRUE
),
actionButton("go", "Go"),
textOutput("filtered_data_bad"),
textOutput("filtered_data_good")
)
server <- function(input, output) {
data <- tibble(
group = rep(c("A", "B"), c(5, 10))
)
group_saved <- reactiveVal(value = c("A"))
observeEvent(
input$go,
group_saved(input$group),
ignoreInit = TRUE,
ignoreNULL = FALSE
)
filter_data <- function (df, .group) {
df[df$group %in% .group,]
# reactive(
# .data[.data$group %in% .group,]
# )
}
format_text <- function (.data, .group) {
req(nrow(.data) > 0)
paste(
"Selected:",
nrow(.data),
"total"
)
}
rv <- reactiveValues(bad=NULL,good=NULL)
observeEvent(input$go, {
group_saved()
rv$bad = filter_data(data, group_saved())
rv$good = data[data$group %in% group_saved(),]
})
output$filtered_data_bad <- renderText({
req(rv$bad)
format_text(rv$bad, group_saved())
})
output$filtered_data_good <- renderText({
req(rv$good)
format_text(rv$good, group_saved())
})
}
shinyApp(ui, server)

In Shiny, await for the user to stop filling a table with rhandsontable

Considering a user filling in by hand a rhandsontable, I would like to implement a time related condition to proceed with table analysis and plot. E.g. if nothing has been added to table during the last 2 seconds, proceed, otherwise await till the 2 seconds are past.
I tried with validate() or simple condition (like below). It does not work because observe() is accessed immediately after table is modified, at that time the time related condition is false. When the condition should be true, the observe() function is not accessed anymore so condition is not tested...
I tried to provide a MRE but I have trouble defending the need for such feature in a simple example. The need is related to computation time of analysis and plot.
library(shiny)
library(rhandsontable)
library(ggplot2)
DF <- data.frame(x=integer(0), y=integer(0))
ui <- shinyUI(fluidPage(
mainPanel(
rHandsontableOutput("hot"),
plotOutput("plot1")
)
))
server <- shinyServer(function(input, output) {
values <- reactiveValues()
values$table <- DF
values$accessDF <- 0
observe({
if (!is.null(input$hot)) {
DF <- hot_to_r(input$hot)
values$accessDF <- Sys.time() # reset awaiting time when table is incremented
} else {
if (is.null(values[["DF"]]))
DF <- DF
else
DF <- values[["DF"]]
}
values[["DF"]] <- DF
})
output$hot <- renderRHandsontable({
rhandsontable(values[["DF"]], stretchH = "all", minRows=5)
})
observe({
if (Sys.time() - values$accessDF > 2){ # unfornate try...
# some modification of the table occuring here
values$table <- values$DF
}
})
output$plot1 <- renderPlot({
ggplot(data=values$table) + geom_line(aes(x=x, y=y))
})
})
shinyApp(ui=ui, server=server)
Another way is to let your plot depend on a debounced reactive expression that contains the reactive value:
library(shiny)
library(rhandsontable)
library(ggplot2)
ui <- shinyUI(fluidPage(
mainPanel(
rHandsontableOutput("hot"),
plotOutput("plot1")
)
))
server <- function(input, output, session) {
rv = reactiveVal(data.frame(x = integer(0), y = integer(0)))
r2 = reactive(rv()) |>
debounce(2000)
output$hot <- renderRHandsontable({
rhandsontable(rv(), stretchH = "all", minRows = 5)
})
output$plot1 <- renderPlot({
ggplot(r2(), aes(x = x, y = y)) +
geom_point(na.rm = TRUE) +
geom_line(na.rm = TRUE)
})
observeEvent(input$hot$changes, {
rv(hot_to_r(input$hot))
})
}
shinyApp(ui = ui, server = server)
I found one solution. Use reactiveTimer() to force the observe() to activate even though no variable it observes has been updated.
in server:
autoInvalidate <- reactiveTimer(200) # to activate observer every 200 ms
and then in observe()
autoInvalidate()
followed by the condition
if (Sys.time() - values$accessDF > 2){ # unfornate try...
# some modification of the table occuring here
values$table <- values$DF
}
see https://shiny.rstudio.com/reference/shiny/1.0.0/reactiveTimer.html

Filtering data.tables in shiny with 2 inputs

Code Below. I want to filter a data.frame based on two inputs. input$SelectGroup4 will be a column name in a data.frame and input$subsetSelect is a value in that column. Is this possible to do? Note: the whole code base is much much larger, so I took out only the key parts to this code. This code probably won't run on it's own, but it's just to get a general idea.
library(shiny)
library(data.table)
ui = fluidPage(
uiOutput('textField'),
uiOutput('docIdField'),
fluidRow(column(4,textInput("keyword", "Enter keyword :", "WB")),
fluidRow(column(4, sliderInput("context", "Enter number of words for context :",
min = 1, max = 10,
value = 5))),
fluidRow(column(4,uiOutput('selectGroup4'))),
fluidRow(column(4,uiOutput('subsetSelect'))),
fluidRow(column(10,DT::dataTableOutput("kwicTable"))))
}
server = function(input,output){
df_corpus1 <- reactive({
dTemp = as.data.table(datasetInput())
dTemp = dTemp %>% filter(input$selectGroup4==input$subsetSelect)
})
output$kwicTable=renderDataTable({
dtemp = df_corpus1()
dtemp = corpus(as.data.frame(dtemp),text_field=input$textField,docid_field=input$docIdField)
x = kwic(x = dtemp,pattern=input$keyword,window=input$context)
x = as.data.table(x)
x[,4:6]
})
}
shinyApp(ui,server)
Yes, you can do that. Since we do not have access to your dataset, here is a working example with the mtcars dataset.
Hope this helps!
library(shiny)
ui <- fluidPage(
selectInput('col','Column',colnames(mtcars)),
uiOutput('ui_col'),
dataTableOutput('table')
)
server <- function(input,output){
# Create a new input element with the unique values of the selected column
output$ui_col <- renderUI({
req(input$col)
selectizeInput('val','Value',unique(mtcars[[input$col]]),multiple=T)
})
# If both inputs are not null, filter the table
output$table <- renderDataTable({
df <- mtcars
if(!is.null(input$col) & !is.null(input$val))
{
df = df[df[[input$col]] %in% input$val,]
}
df
})
}
shinyApp(ui = ui, server = server)

RShiny: modify numericInput based on data

Here's a sample code where I generate random vector and plot its histogram. In addition, there's a numericInput field that I use to clip data, i.e. to assign values lower than a threshold to that threshold. The initial value of the numericInput field is assigned based on data.
The problem is that when I press the button to generate data, the plot is evaluated twice, which I want to avoid. I emphasise this by adding sleep routine in the plotting function.
It seems to me that I'm updating the numericInput incorrectly. When I simply hard-code initial field value of that field, the issue is gone and the plot is evaluated once.
library(shiny)
ui <- shinyUI(fluidPage(
titlePanel("test data clipping"),
sidebarLayout(
sidebarPanel(
actionButton('inDataGen', 'Generate dataset'),
br(),
br(),
uiOutput('resetable_input_clip'),
actionButton('inDataClipReset', 'Reset data clipping')
),
mainPanel(plotOutput("plotHist", width = "100%"))
)
))
server <- shinyServer(function(input, output) {
rValues <- reactiveValues(dataIn = NULL,
dataMin = -10e10)
# generate random dataset
userDataGen <- observeEvent(input$inDataGen, {
cat(file = stderr(), '\nuserDataGen\n')
# assign result to shared 'dataIn' variable
x <- rnorm(1000)
rValues$dataIn = x
rValues$dataMin = min(x)
})
# modify data
userDataProc <- reactive({
cat(file = stderr(), 'userDataProc\n')
dm = rValues$dataIn
if (is.null(rValues$dataIn))
return(NULL)
else {
# Data clipping
dm[dm < input$inDataClipMin] <-
input$inDataClipMin
return(dm)
}
})
output$resetable_input_clip <- renderUI({
cat(file = stderr(), 'output$resetable_input_clip\n')
times <- input$inDataClipReset
div(
id = letters[(times %% length(letters)) + 1],
numericInput(
'inDataClipMin',
'Clip data below threshold:',
value = rValues$dataMin,
width = 200,
step = 100
)
)
})
output$plotHist <- renderPlot({
cat(file = stderr(), 'plotHist \n')
if (is.null(rValues$dataIn))
return(NULL)
else {
plot(hist(userDataProc()))
Sys.sleep(2)
}
})
})
shinyApp(ui = ui, server = server)
The flow after pressing the button to generate data involves two evaluations of plotHist:
output$resetable_input_clip
plotHist
userDataGen
plotHist
userDataProc
output$resetable_input_clip
plotHist
userDataProc
SOLVED ELSWHERE
This issue has been solved on Shiny Google group. The final solution is available here and is a combination of changing observeEvent + reactiveValues to reactive(), and using freezeReactiveValue.
I believe your issue is occurring in
# modify data
userDataProc <- reactive({
cat(file = stderr(), 'userDataProc\n')
dm = rValues$dataIn
if (is.null(df))
return(NULL)
else {
# Data clipping
dm[dm < input$inDataClipMin] <-
input$inDataClipMin
return(dm)
}
})
Since input$inDataClipMin is dependent on the reactive value rValues$dataMin, you end up rendering this for the initial value of rValues$dataMin, the rValues$dataMin is being reevaluated, which triggers a reevaluation of input$inDataClipMin.
If you replace this snippet with what I have below, you should get your desired behavior.
# modify data
userDataProc <- reactive({
cat(file = stderr(), 'userDataProc\n')
dm = rValues$dataIn
if (is.null(df))
return(NULL)
else {
# Data clipping
dm[dm < rValues$dataMin] <-
rValues$dataMin
return(dm)
}
})
As an alternative, you could put the following in your ui
numericInput(
'inDataClipMin',
'Clip data below threshold:',
value = rValues$dataMin,
width = 200,
step = 100
)
And then use updateNumericInput to replace it's value. This would require a lot more tinkering in your current code, however, and depending on what else is happening in your app, may not be the ideal solution anyway.
Here's what I came up with. The key difference is introduction of a shared reactive variable rValues$dataClip that stores clipped data. Previously, data modification was achieved by a reactive function userDataProc. The output of that function was used for plotting which, as suggested by #Benjamin, was the culprit of double evaluation of plotting. In this version, the userDataProc is turned into observeEvent that monitors input$inDataClipMin numeric input field.
library(shiny)
ui <- shinyUI(fluidPage(
titlePanel("test data clipping"),
sidebarLayout(
sidebarPanel(
actionButton('inDataGen', 'Generate dataset'),
br(),
br(),
uiOutput('resetable_input_clip'),
actionButton('inDataClipReset', 'Reset data clipping')
),
mainPanel(plotOutput("plotHist", width = "100%"))
)
))
server <- shinyServer(function(input, output, session) {
rValues <- reactiveValues(dataIn = NULL,
dataClip = NULL,
dataMin = -10e10)
# generate random dataset
userDataGen <- observeEvent(input$inDataGen, {
cat(file = stderr(), '\nuserDataGen\n')
# assign result to shared 'dataIn' variable
x <- rnorm(1000)
rValues$dataIn = x
rValues$dataMin = min(x)
})
# modify data
userDataProc <- observeEvent(input$inDataClipMin, {
cat(file = stderr(), 'userDataProc\n')
dm = rValues$dataIn
if (is.null(rValues$dataIn))
rValues$dataClip = NULL
else {
dm[dm < input$inDataClipMin] <-
input$inDataClipMin
rValues$dataClip <- dm
}
})
output$resetable_input_clip <- renderUI({
cat(file = stderr(), 'output$resetable_input_clip\n')
times <- input$inDataClipReset
div(
id = letters[(times %% length(letters)) + 1],
numericInput(
'inDataClipMin',
'Clip data below threshold:',
value = rValues$dataMin,
width = 200,
step = 100
)
)
})
output$plotHist <- renderPlot({
cat(file = stderr(), 'plotHist \n')
if (is.null(rValues$dataClip))
return(NULL)
else {
plot(hist(rValues$dataClip))
Sys.sleep(2)
}
})
})
shinyApp(ui = ui, server = server)
Now, there's only one evaluation of plotHist after pressing the button to generate data:
output$resetable_input_clip
plotHist
userDataProc
userDataGen
output$resetable_input_clip
userDataProc
plotHist

Resources