In the MRE below, the user is asked to filled in a table from which a curved is plotted. To mimic some computation, occurring on the table before producing graphical output, I added a Sys.sleep(). You will see that if the table is filled sufficiently fast, i.e. faster than the Sys.sleep(), the application become unusable and have to be killed.
I believe this is because table rendering is occurring after computation/sleep and plot rendering. How should I address this issue to make the app react in real time and still be usable ?
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()
observe({
if (!is.null(input$hot)) {
DF <- hot_to_r(input$hot)
} 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)
})
output$plot1 <- renderPlot({
table <- {
Sys.sleep(.4)
values[["DF"]]
}
ggplot(data=table) + geom_line(aes(x=x, y=y))
})
})
shinyApp(ui=ui, server=server)
Related
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}.
Trying to understand how to create observeEvent()'s to catch changes to an arbitrary number of dynamically-created RHandsontables. Has anyone successfully done this before?
The code below shows creation of the dynamic tables. The comments towards the bottom indicate the inputs I would like to track, but the observeEvents need to account for an arbitrary set of input names.
library(shiny)
library(dplyr)
library(rhandsontable)
library(purrr)
ui <- fluidPage(
uiOutput('tables')
)
server <- function(input, output) {
mtcars$slc <- sample(c('aaa','bbb'),nrow(mtcars),replace=TRUE)
df <- mtcars
getSlice <- function(df_tmp,slca){
print(slca)
df_tmp <- df_tmp %>% filter(slc==slca)
df_tmp
}
output$tables <- renderUI({
slices <- unique(df$slc)
input_dfs <- map(slices,~getSlice(df,.x))
for(i in 1:length(slices)){
local({
i <- i
print(input_dfs[[i]])
output[[slices[i]]] <- renderRHandsontable(rhandsontable(input_dfs[[i]]))
})
}
out <- map(slices,function(x){
rHandsontableOutput(x)
})
print(out)
out
})
### How do I create observeEvents for...
# input$aaa$changes$changes
# input$bbb$changes$changes
# input$arbitrarySlice$changes$changes
}
shinyApp(ui = ui, server = server)
You can iteratively add observeEvents using lapply() as shown:
library(shiny)
library(dplyr)
library(rhandsontable)
library(purrr)
ui <- fluidPage(
uiOutput("tables")
)
server <- function(input, output) {
mtcars$slc <- sample(c("aaa", "bbb"), nrow(mtcars), replace = TRUE)
df <- mtcars
getSlice <- function(df_tmp, slca) {
print(slca)
df_tmp <- df_tmp %>% filter(slc == slca)
df_tmp
}
output$tables <- renderUI({
slices <- unique(df$slc)
input_dfs <- map(slices, ~ getSlice(df, .x))
for (i in 1:length(slices)) {
local({
i <- i
print(input_dfs[[i]])
output[[slices[i]]] <- renderRHandsontable(rhandsontable(input_dfs[[i]]))
})
}
out <- map(slices, function(x) {
rHandsontableOutput(x)
})
print(out)
out
})
### How do I create observeEvents for...
# input$aaa$changes$changes
# input$bbb$changes$changes
# input$arbitrarySlice$changes$changes
### Iteratively add observeEvent()
lapply(unique(df$slc), function(slice) {
observeEvent(input[[slice]]$changes$changes, {
print(paste(slice, "has been updated!"))
print(input[[slice]][["changes"]])
})
})
}
shinyApp(ui = ui, server = server)
I have the data frame below:
Name<-c("John","Bob","Jack")
Number<-c(3,3,5)
NN<-data.frame(Name,Number)
And a simple shiny app which creates a plotly histogram out of it. My goal is to click on a bar of the histogram and display the Name in a datatable that correspond to this bar. For example if I click on the first bar which is 3 I will take a table with John and Bob names.
library(plotly)
library(shiny)
library(DT)
ui <- fluidPage(
mainPanel(
plotlyOutput("heat")
),
DT::dataTableOutput('tbl4')
)
server <- function(input, output, session) {
output$heat <- renderPlotly({
p <- plot_ly(x = NN$Number, type = "histogram")
})
output$tbl4 <- renderDataTable({
s <- event_data("plotly_click")
if (length(s) == 0) {
"Click on a bar in the histogram to see its values"
} else {
NN[ which(NN$Number==as.numeric(s[2])), 1]
}
})
}
shinyApp(ui, server)
I am adding the solution by modifying your data.frame as mentioned in the comment:
library(plotly)
library(shiny)
library(DT)
ui <- fluidPage(
mainPanel(
plotlyOutput("heat")
),
DT::dataTableOutput('tbl4')
)
server <- function(input, output, session) {
output$heat <- renderPlotly({
Name<-c("John","Bob","Jack")
Number<-c(3,3,5)
Count<-c(2,2,1)
NN<-data.frame(Name,Number,Count)
render_value(NN) # You need function otherwise data.frame NN is not visible
p <- plot_ly(x = NN$Number, type = "histogram",source="subset") # set source so
# that you can get values from source using click_event
})
render_value=function(NN){
output$tbl4 <- renderDataTable({
s <- event_data("plotly_click",source = "subset")
print(s)
return(DT::datatable(NN[NN$Count==s$y,]))
})
}
}
shinyApp(ui, server)
Screenshot from solution:
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
I know renderPlot produces plot that can be shown on Shiny plotOutput function. I also know autoinvalidate() helps to calculate data reactively.
I am displaying a radar chart (in fact can be any chart) using the below codes:
output$plot2 <- renderPlot({
autoInvalidate()
p2<<-ggradar(mtcars_radar[i,])
})
What I dont know is how to change the value of i from 1 to 300 during every event of autoinvalidate().
Or is there anyway I can change the row of data in plot so that the plot is dynamically animating every sec with a new row of data.
Can anyone help me plz?
The full code is here:
library(shiny)
library(ggplot2)
mtcars %>%
rownames_to_column( var = "group" ) %>%
mutate_at(vars(-group),funs(rescale)) %>%
tail(4) %>% select(1:10) -> mtcars_radar
ui <- fluidPage(
sidebarPanel(
actionButton("button", "Go!")
),
# Show the plot
mainPanel(
plotOutput("plot2")
)
)
server <- function(input, output) {
library(ggplot2)
library(ggradar)
suppressPackageStartupMessages(library(dplyr))
library(scales)
autoInvalidate <- reactiveTimer(2000)
plot2 <- NULL
output$plot2 <- renderPlot({
ggradar(mtcars_radar[1,])
})
observeEvent(input$button,{
output$plot2 <- renderPlot({
autoInvalidate()
p2<<-ggradar(mtcars_radar[i,])
p2
})
})
}
# Run the application
shinyApp(ui = ui, server = server)
Any help please?
This is where you need a reactive value that stores the row index and changes every second. I do not have the library ggradar, so I will just print out the current row index value instead. I also used invalidateLater instead of reactiveTimer as suggested by Shiny documentation.
library(shiny)
ui <- fluidPage(
verbatimTextOutput("debug")
)
server <- function(input, output) {
row_idx_max <- 15
row_idx <- reactiveVal(0)
observe({
isolate(row_idx(row_idx() + 1))
cur_row_idx <- isolate(row_idx())
if (cur_row_idx < row_idx_max) {
invalidateLater(1000)
}
})
output$debug <- renderPrint({
row_idx()
})
}
shinyApp(ui, server)