I'm working on a shiny app that streams data and am updating the UI via renderTable every second. When the app renders the table dims between each update which is annoying from a visual perspective. Is there a way to disable this behavior?
output$table_state <- renderTable({
invalidateLater(1000)
get_table_state()
})
If get_table_state() performs a long computation, you can try to execute it outside renderTable(). Notice the use of observe here.
Example app
library(shiny)
library(tidyverse)
long_calculation <- function() {
Sys.sleep(1)
iris
}
ui <- fluidPage(
fluidRow(
column(width = 6,
tableOutput('table_slow')),
column(width = 6, tableOutput('table2')))
)
server <- function(input, output, session) {
df <- reactiveValues(x = NULL)
output$table_slow <- renderTable({
invalidateLater(1000)
long_calculation()
})
iris_no_dim <- observe({
invalidateLater(1000)
df$x <- long_calculation()})
output$table2 <- renderTable({
df$x
})
}
shinyApp(ui, server)
Related
In the below code for a Shiny app, I am expecting the print line to execute when the user clicks on a new row in the datatable. When I do this, the textOutput updates with the selected row via input$table_rows_selected as expected. But why does change <- reactive({ }) not take a dependency on changes to input$table_rows_selected and trigger the print message?
I see that it works with observe({}) but ultimately I want to use a value that reactive returns in different places (e.g here return and return2).
library(shiny)
library(DT)
ui <- fluidPage(
DT::DTOutput("table"),
textOutput("selected"),
textOutput("return"),
textOutput("return2")
)
server <- function(input, output) {
output$table <- DT::renderDataTable({
data.frame(a = 1:3, b = 4:6)
}, selection = 'single')
output$selected <- renderText({
input$table_rows_selected
})
change <- reactive({
input$table_rows_selected
print("it changed!")
"return"
})
output$return <- renderText({
isolate(change())
})
output$return2 <- renderText({
paste0(isolate(change()), "_2")
})
}
# Run the application
shinyApp(ui = ui, server = server)
Your code has 2 problems:
a reactive is just a function, therefore its return value is the last value generated in the reactive -> you need to put input$table_rows_selected last
the isolate(change()) means that reactives don't have a dependency on input$table_rows_selected -> remove the isolate
library(shiny)
library(DT)
ui <- fluidPage(
DT::DTOutput("table"),
textOutput("selected"),
textOutput("return"),
textOutput("return2")
)
server <- function(input, output) {
output$table <- DT::renderDataTable({
data.frame(a = 1:3, b = 4:6)
}, selection = 'single')
output$selected <- renderText({
input$table_rows_selected
})
change <- reactive({
print("it changed!")
input$table_rows_selected
})
output$return <- renderText({
change()
})
output$return2 <- renderText({
paste0(change(), "_2")
})
}
# Run the application
shinyApp(ui = ui, server = server)
I'm making an app in which the user can create as many tables as he/she wants and display the code necessary to remake each individual table using shinymeta. I can generate the code for each of these tables but I have a problem when I want to create a complete modal that shows every code for each table.
To be clearer, here's a reproducible example:
library(shiny)
library(dplyr)
library(shinymeta)
module_ui <- function(id){
ns <- NS(id)
tagList(
fluidRow(
actionButton(ns("show_table"), "Show table"),
actionButton(ns("show_code"), "Show code"),
tableOutput(ns("table"))
)
)
}
module_server <- function(input, output, session){
data <- metaReactive2({
req(input$show_table)
isolate(metaExpr({
mtcars
}))
})
data2 <- metaReactive({
..(data()) %>%
select(mpg)
})
output$table <- renderTable({
data2()
})
observeEvent(input$show_code, {
showModal(modalDialog(
renderPrint({
expandChain(data(), data2())
})
))
})
return(data())
}
ui <- fluidPage(
actionButton("launch", "Launch"),
actionButton("show_full_code", "Show the full code (at least 2 'launch' before)")
)
server <- function(input, output, session) {
count <- reactiveValues(value = 0)
observeEvent(input$launch, {
count$value <- count$value + 1
insertUI(selector = "#show_full_code",
where = "afterEnd",
ui = module_ui(paste0("x", count$value)))
callModule(module_server, paste0("x", count$value))
})
#### "Merge" the single code modals in one big
observeEvent(input$show_full_code, {
showModal(modalDialog(
renderPrint({
expandChain(x1_data)
})
))
})
}
shinyApp(ui, server)
When you click on "Launch", two buttons are generated and you can display a table ("Show table") and the code to remake this table ("Show code"). You can click on "Launch" indefinitely and the table will be named x1_data, x2_data, etc.
However, when I try to generate the code that unites every individual code (by clicking on "Show the full code"), x1_data is not found. Using x1_data() does not work either. I'm not a fan of asking two questions in one post but I will do this now:
How can I access the reactive elements created inside modules?
How can I "merge" every individual code in a big one?
Also asked on RStudio Community
Edit: following a comment, I add a second reactive expression in my example, so that I can't use return on both of them.
Ok, I came up with an answer that has the module return the expandChain() results rather than trying to render them again in the server:
library(shiny)
library(dplyr)
library(shinymeta)
module_ui <- function(id){
ns <- NS(id)
tagList(
fluidRow(
actionButton(ns("show_table"), "Show table"),
actionButton(ns("show_code"), "Show code"),
tableOutput(ns("table"))
)
)
}
module_server <- function(input, output, session){
data <- metaReactive2({
req(input$show_table)
isolate(metaExpr({
mtcars
}))
})
data2 <- metaReactive({
..(data()) %>%
select(mpg)
})
output$table <- renderTable({
data2()
})
observeEvent(input$show_code, {
showModal(modalDialog(
renderPrint({
expandChain(data(), data2())
})
))
})
########################################
### create list of reactive objects ####
########################################
return(list(
expandChain(data(), data2())
)
)
}
ui <- fluidPage(
actionButton("launch", "Launch"),
actionButton("show_full_code", "Show the full code (at least 2 'launch' before)")
)
server <- function(input, output, session) {
count <- reactiveValues(value = 0)
observeEvent(input$launch, {
count$value <- count$value + 1
insertUI(selector = "#show_full_code",
where = "afterEnd",
ui = module_ui(paste0("x", count$value)))
callModule(module_server, paste0("x", count$value))
})
#### "Merge" the single code modals in one big list object
my_data <- reactive({
req(count$value)
my_set <- 1:count$value
### lapply through the different name spaces so all are captured ###
final <- lapply(my_set, function(x){
temp <- callModule(module_server, paste0("x", x))
return(temp)
})
return(final)
})
#### "Merge" the single code modals in one big
observeEvent(input$show_full_code, {
showModal(modalDialog(
renderPrint({
temp <- sapply(unlist(my_data()), function(x){
print(x)
})
})
))
})
}
shinyApp(ui, server)
I am new to asynchronous programming in R with the Future Package so needed some help. I am trying to build a simple application with rshiny which supports asynchronous programming. So my code as a histogram plot, a slider, a simple text print and read.csv function to read a large CSV file. So my plan is before my read.csv function runs in the background using the future package in R, I would like to have control over my other application.
But my code waits for the CSV file to read. Any help will be appreciated. The code sample is below.
library(promises)
library(future)
library(shinydashboard)
library(shiny)
library(tidyverse)
plan(multiprocess)
#UI parts
ui <- dashboardBody(fluidRow(box(tableOutput("input1")),
box(textOutput("input2"))),
fluidRow(box(
sliderInput(
inputId = "bins",
label = "Number of bins:",
min = 1,
max = 5,
value = 2
)
),
box(plotOutput(outputId = "distPlot"))),
fluidRow(box(
sliderInput(
"slider2",
label = h3("Slider Range"),
min = 0,
max = 100,
value = c(40, 60)
)
),
box(verbatimTextOutput("range"))))
#server part
server <- function(input, output, session) {
output$input1 <- renderTable({
promise <- future((read.csv("data/sample_large.csv")))
promise %...>% head() %...>% print()
})
output$input2 <- renderText({
print("hello")
})
output$distPlot <- renderPlot({
dist <- rnorm(input$bins)
hist(dist)
})
output$range <- renderPrint({
input$slider2
})
}
shinyApp(ui = dashboardPage(dashboardHeader(),
dashboardSidebar(),
ui),
server = server)
The behaviour you're experiencing where the rest of the UI is not loading until the promise is evaluated is expected behaviour. It is explained in the promises package as part of what they call the 'shiny flush cycle' and is described in more detail here and here.
Only after all of the outputs have completed executing are they sent back to Shiny to update the UI. You may expect/prefer outputs to be rendered as soon as they are ready but unfortunately that's not how Shiny operates.
As noted in the second link you can 'trick' shiny into thinking all outputs are executed and then use a reactive value to trigger the final update once the promise has evaluated:
#server part
server <- function(input, output, session) {
data <- reactiveVal()
# Return NULL from this operation so Shiny 'thinks' the output is evaluated
observe({
data(NULL)
future({read.csv("data/sample_large.csv")}) %...>%
data() #Assign to data
NULL
})
# When data() is updated as a side effect of our promise the table will be updated
output$input1 <- renderTable({
req(data()) %>%
head(5) %>%
print()
})
# in the mean time all outputs will be judged to be complete so can be rendered
output$input2 <- renderText({
print("hello")
})
output$distPlot <- renderPlot({
dist <- rnorm(input$bins)
hist(dist)
})
output$range <- renderPrint({
input$slider2
})
}
shinyApp(ui = dashboardPage(dashboardHeader(),
dashboardSidebar(),
ui),
server = server)
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)
I have created a large number of data tables using mapply, however, I need to access the data tables in a following step. R assigns random IDs to these tables if the user does not specify the IDs. Here is an example of what I would like to do:
library(shiny)
ui <- fluidPage(
h2("Last clicked:"),
verbatimTextOutput("last_clicked"),
actionButton("reset", "Reset clicked value"),
h2("Datatable:"),
DT::dataTableOutput("dt")
)
server <- function(input, output) {
# the last clicke value
output$last_clicked <- renderPrint({
str(last())
})
output$dt <- DT::renderDataTable({
DT::datatable(head(mtcars, 2), elementId = "DT_Test")
})
observeEvent(input$dt_cell_clicked, {
validate(need(length(input$dt_cell_clicked) > 0, ''))
print("You clicked something!")
})
myProxy = DT::dataTableProxy('dt')
last = reactiveVal(NULL)
observe({
last(input$dt_cell_clicked)
})
observeEvent(input$reset, {
DT::selectRows(myProxy, NULL)
last(NULL)
output$dt <- DT::renderDataTable({
DT::datatable(head(mtcars, 2))
})
})
}
shinyApp(ui, server)
If I look at the html, the elementID did not change to what I wanted, in fact, R gives the warning:
Warning in origRenderFunc() :
Ignoring explicitly provided widget ID "DT_Test"; Shiny doesn't use them
Even after the call, still not sure what you are trying to do.
But if you have a list of datatables and you want to access them, it works rather well like this:
library(shiny)
library(purrr)
ui <- fluidPage(
h2("Last clicked:"),
verbatimTextOutput("last_clicked"),
h2("elementId values"),
verbatimTextOutput("elementId_values"),
actionButton("reset", "Reset clicked value"),
h2("Datatable:"),
DT::dataTableOutput("dt")
)
server <- function(input, output) {
# the last clicke value
output$last_clicked <- renderPrint({
str(last())
})
table <- DT::datatable(head(mtcars, 2), elementId = "DT_Test")
table2 <- DT::datatable(tail(mtcars, 1), elementId = "DT_Test2")
list_of_data_tables <- list(table, table2)
element_ids <- purrr::map(list_of_data_tables, "elementId")
output$elementId_values <- renderPrint({
element_ids
})
output$dt <- DT::renderDataTable({
list_of_data_tables[[which(element_ids == "DT_Test2")]]
})
observeEvent(input$dt_cell_clicked, {
validate(need(length(input$dt_cell_clicked) > 0, ''))
print("You clicked something!")
})
myProxy = DT::dataTableProxy('dt')
last = reactiveVal(NULL)
observe({
last(input$dt_cell_clicked)
})
observeEvent(input$reset, {
DT::selectRows(myProxy, NULL)
last(NULL)
output$dt <- DT::renderDataTable({
DT::datatable(head(mtcars, 2))
})
})
}
shinyApp(ui, server)