Asynchronous Shiny app.

asynchronousShinyApp.gif

asynchronousShinyApp.R

library(shiny)
library(DT)
library(plotly)
library(chron)
library(promises)
library(future)
plan(multisession)

longProcess <- function(wait) {
  start <- Sys.time()
  Sys.sleep(wait)
  end   <- Sys.time()
  data.frame(
    start    = as.character(times(strftime(start, "%H:%M:%S"))),
    end      = as.character(times(strftime(end,   "%H:%M:%S"))),
    duration = paste(round(end - start, 1L), "sec")
  )
}

ui <- fluidPage(
  tags$head(
    tags$style(
      HTML(
        "#text { font-weight: bold; font-size: 22px;}"
      )
    )
  ),
  titlePanel("Asynchronous Shiny app"),
  sidebarLayout(
    sidebarPanel(
      br(),
      wellPanel(
        style = "background-color: yellow;",
        textOutput("text")
      ),
      br(),
      actionButton(
        "SimulateAsyncProcesses", 
        "Simulate long process.", 
        class = "btn-block"
      ), 
      br(), br(),
      actionButton(
        "GenerateDataToPlot", 
        "Generate plot.",
        class = "btn-block"
      )
    ),
    mainPanel(
      fluidRow(
        column(
          4, 
          DTOutput("ProcessInfo")
        ),
        column(
          8, 
          plotlyOutput("GeneratedHeatMap", height = "350px")
        )
      )
    )
  )
)

server <- function(input, output, session) {
  
  Text <- reactiveVal(
    "Hello. Click the first button."
  )
  
  output[["text"]] <- renderText({
    Text()
  })
  
  ProcessInfo <- reactiveVal()

  observeEvent(input[["SimulateAsyncProcesses"]], {
    Text(
      paste(
        "The long process is running but you don't need to wait!",
        "You can generate the plot now."
      )
    )
  })
  
  observeEvent(input[["GenerateDataToPlot"]], {
    Text("Now wait...")
  })
  
  Promise <- eventReactive(input[["SimulateAsyncProcesses"]], {
    future_promise(longProcess(10L)) %...>% ProcessInfo()
  })
  
  output[["ProcessInfo"]] <- renderDT({
    req(Promise())
    datatable(ProcessInfo(), rownames = FALSE, options = list(dom = "t"))
  })

  observeEvent(ProcessInfo(), {
    Text("The long process is done!")  
  })
  
  # plot stuff ####
  DataToPlot <- eventReactive(input[["GenerateDataToPlot"]], {
    matrix(runif(100L), nrow = 10L, ncol = 10L)
  })
  
  output[["GeneratedHeatMap"]] <- renderPlotly({
    req(DataToPlot())
    plot_ly(z = DataToPlot(), type = "heatmap")
  })
  
}


shinyApp(ui = ui, server = server)

asynchronousShinyApp_callr.R

library(shiny)
library(DT)
library(plotly)
library(chron)
library(callr)

longProcess <- function(wait) {
  start <- Sys.time()
  Sys.sleep(wait)
  end   <- Sys.time()
  data.frame(
    start    = as.character(strftime(start, "%H:%M:%S")),
    end      = as.character(strftime(end,   "%H:%M:%S")),
    duration = paste(round(end - start, 1L), "sec")
  )
}

ui <- fluidPage(
  tags$head(
    tags$style(
      HTML(
        "#text { font-weight: bold; font-size: 22px;}"
      )
    )
  ),
  titlePanel("Asynchronous Shiny app"),
  sidebarLayout(
    sidebarPanel(
      br(),
      wellPanel(
        style = "background-color: yellow;",
        textOutput("text")
      ),
      br(),
      actionButton(
        "SimulateAsyncProcesses", 
        "Simulate long process.", 
        class = "btn-block"
      ), 
      br(), br(),
      actionButton(
        "GenerateDataToPlot", 
        "Generate plot.",
        class = "btn-block"
      )
    ),
    mainPanel(
      fluidRow(
        column(
          4, 
          DTOutput("ProcessInfo")
        ),
        column(
          8, 
          plotlyOutput("GeneratedHeatMap", height = "350px")
        )
      )
    )
  )
)

server <- function(input, output, session) {
  
  Text <- reactiveVal(
    "Hello. Click the first button."
  )
  
  output[["text"]] <- renderText({
    Text()
  })
  
  #ProcessInfo <- reactiveVal()

  observeEvent(input[["SimulateAsyncProcesses"]], {
    Text(
      paste(
        "The long process is running but you don't need to wait!",
        "You can generate the plot now."
      )
    )
  })
  
  observeEvent(input[["GenerateDataToPlot"]], {
    Text("Now wait...")
  })
  
  PromisedTable <- eventReactive(input[["SimulateAsyncProcesses"]], {
    callr::r_bg(
      longProcess, args = list(wait = 10L)
    )
  })
  
  ProcessDone <- reactive({
    if(PromisedTable()$is_alive()) {
      invalidateLater(millis = 1000, session = session)
      NULL
    } else {
      TRUE
    }
  })
  
  output[["ProcessInfo"]] <- renderDT({
    req(ProcessDone())
    datatable(PromisedTable()$get_result(), rownames = FALSE, options = list(dom = "t"))
  })

  observeEvent(ProcessDone(), {
    Text("The long process is done!")  
  })
  
  # plot stuff ####
  DataToPlot <- eventReactive(input[["GenerateDataToPlot"]], {
    matrix(runif(100L), nrow = 10L, ncol = 10L)
  })
  
  output[["GeneratedHeatMap"]] <- renderPlotly({
    req(DataToPlot())
    plot_ly(z = DataToPlot(), type = "heatmap")
  })
  
}


shinyApp(ui = ui, server = server)

test.R

library(shiny)
library(ggplot2)
library(chron)

longProcess <- function(wait) {
  start <- Sys.time()
  Sys.sleep(wait)
  end   <- Sys.time()
  data.frame(
    start    = as.character(times(strftime(start, "%H:%M:%S"))),
    end      = as.character(times(strftime(end,   "%H:%M:%S"))),
    duration = paste(round(end - start, 1L), "sec")
  )
}

ui <- fluidPage(
  tags$head(
    tags$style(
      HTML(
        "#text { font-weight: bold; font-size: 22px;}"
      )
    )
  ),
  titlePanel("Asynchronous Shiny app"),
  sidebarLayout(
    sidebarPanel(
      br(),
      wellPanel(
        style = "background-color: yellow;",
        textOutput("text")
      ),
      br(),
      actionButton(
        "SimulateAsyncProcesses", 
        "Simulate long process.", 
        class = "btn-block"
      ), 
      br(), br(),
      actionButton(
        "GenerateDataToPlot", 
        "Generate plot.",
        class = "btn-block"
      )
    ),
    mainPanel(
      fluidRow(
        column(
          4, 
          tableOutput("ProcessInfo")
        ),
        column(
          8, 
          plotOutput("GeneratedHeatMap", height = "350px")
        )
      )
    )
  )
)

server <- function(input, output, session) {
  
  Text <- reactiveVal(
    "Hello. Click the first button."
  )
  
  output[["text"]] <- renderText({
    Text()
  })
  
  ProcessInfo <- reactiveVal()
  
  observeEvent(input[["SimulateAsyncProcesses"]], {
    Text(
      paste(
        "The long process is running but you don't need to wait!",
        "You can generate the plot now."
      )
    )
  })
  
  observeEvent(input[["GenerateDataToPlot"]], {
    Text("Now wait...")
  })
  
  Promise <- eventReactive(input[["SimulateAsyncProcesses"]], {
    ProcessInfo(longProcess(10L))
  })
  
  output[["ProcessInfo"]] <- renderTable({
    req(Promise())
    ProcessInfo()
  })
  
  observeEvent(ProcessInfo(), {
    Text("The long process is done!")  
  })
  
  # plot stuff ####
  DataToPlot <- eventReactive(input[["GenerateDataToPlot"]], {
    matrix(runif(100L), nrow = 10L, ncol = 10L)
  })
  
  output[["GeneratedHeatMap"]] <- renderPlot({
    req(DataToPlot())
    ggplot(iris) + geom_point(aes(x=Sepal.Width, y=Sepal.Length))
  })
  
}


shinyApp(ui = ui, server = server)