Skip to content

Commit

Permalink
Add extended task option to coin flip app
Browse files Browse the repository at this point in the history
  • Loading branch information
@wlandau
wlandau committed Apr 11, 2024
1 parent 945c6a3 commit 06c87b9
Showing 1 changed file with 204 additions and 106 deletions.
310 changes: 204 additions & 106 deletions vignettes/shiny.Rmd
View file
Original file line number Diff line number Diff line change
Expand Up @@ -15,9 +15,157 @@ vignette: >

`crew` is simple to use inside Shiny apps. Not only does `crew` bring parallel computing to a single app session, it elastically auto-scales worker processes to reduce the resource burden on other concurrent user sessions. And because of the [centralized controller interface](https://wlandau.github.io/crew/reference/crew_class_controller.html), there is no need to manually loop through individual tasks, which is convenient for workloads with thousands of tasks.

# Example: generative art

The simple example below has three interface elements: an action button, a plot output, and a text output. When you click the action button, a new 5-second task pushes to the `crew` controller. The action button can submit new tasks even when existing tasks are running in the background. The plot output shows the random visualization returned from latest task.

The text output continuously refreshes to show the current time and number of tasks in progress. Watch the short video linked below to see the app in action. You will see the time tick away even as tasks run in the background. In other words, the tasks run asynchronously and do not block the app session.

[![](./figures/art.png)](https://vimeo.com/927130003)

## Prerequisites

The example app uses extended tasks, which are only available in Shiny 1.8.1.1 or above. If your installed version of Shiny is too low, you can upgrade to the development version with:

```r
remotes::install_github("rstudio/shiny")
```

## Tutorial

To begin, the app script loads Shiny.

```r
library(shiny)
```

The `run_task()` function waits 5 seconds and then generates a random [`aRtsy::canvas_squares()`](https://koenderks.github.io/aRtsy/reference/canvas_squares.html) plot.

```r
run_task <- function() {
Sys.sleep(5)
aRtsy::canvas_squares(colors = aRtsy::colorPalette("random-palette"))
}
```

The [user interface](https://shiny.rstudio.com/articles/basics.html) shows the three parts explained previously, along with HTML/CSS formatting.

```r
ui <- fluidPage(
tags$br(),
tags$style("#status,#task{font-size:3em}"),
tags$style("#task{border:3px solid black}"),
actionButton("task", "Submit a task (5 seconds)"),
textOutput("status"),
plotOutput("result")
)
```

The [server](https://shiny.rstudio.com/articles/basics.html) sets up a [local process controller](https://wlandau.github.io/crew/reference/crew_controller_local.html). The controller has 4 workers, and each worker automatically shuts down if 10 seconds pass without any task assignments. The `onStop()` statement says to terminate the controller when the app session terminates.

```r
server <- function(input, output, session) {
controller <- crew::crew_controller_local(workers = 4, seconds_idle = 10)
controller$start()
onStop(function() controller$terminate())
```

The `task` object below is a Shiny extended task which accepts a promise object from the controller. The `crew` promise resolves when a task completes, and the `ExtendedTask` object efficiently manages a queue of such promises.^[For more on extended tasks, install the development version of Shiny and call `?shiny::ExtendedTask` to view the help file.]
^[For more on `crew` promises, visit <https://wlandau.github.io/crew/articles/promises.html>.]

```r
task <- ExtendedTask$new(function() controller$promise(mode = "one"))
```

The "Submit a task (5 seconds)" button pushes a new task to the controller and enqueues a new promise to asynchronously handle the result.

```r
observeEvent(input$task, {
controller$push(command = run_task(), data = list(run_task = run_task))
task$invoke()
})
```

Because of the Shiny extended task and the `crew` promise, the plot output automatically refreshes almost immediately after the task completes.

```r
output$result <- renderPlot(task$result()$result[[1L]])
```

The text status periodically refreshes to show the current time and the number of tasks in progress. When you run the app, you will see the time tick away even as tasks and promises operate in the background.

```r
output$status <- renderText({
input$task
task$status()
invalidateLater(millis = 1000)
time <- format(Sys.time(), "%H:%M:%S")
paste("Time:", time, "|", "Running tasks:", controller$unresolved())
})
}
```

Finally, `shinyApp()` runs the app with the UI and server defined above.

```r
shinyApp(ui = ui, server = server)
```

## Code

See below for the complete `app.R` file.

```r
library(shiny)

run_task <- function() {
Sys.sleep(5)
aRtsy::canvas_squares(colors = aRtsy::colorPalette("random-palette"))
}

ui <- fluidPage(
tags$br(),
tags$style("#status,#task{font-size:3em}"),
tags$style("#task{border:3px solid black}"),
actionButton("task", "Submit a task (5 seconds)"),
textOutput("status"),
plotOutput("result")
)

server <- function(input, output, session) {
# crew controller
controller <- crew::crew_controller_local(workers = 4, seconds_idle = 10)
controller$start()
onStop(function() controller$terminate())

# extended task to get completed results from the controller
task <- ExtendedTask$new(function() controller$promise(mode = "one"))

# button to submit a crew task
observeEvent(input$task, {
controller$push(command = run_task(), data = list(run_task = run_task))
task$invoke()
})

# task result
output$result <- renderPlot(task$result()$result[[1L]])

# time and task status
output$status <- renderText({
input$task
task$status()
invalidateLater(millis = 1000)
time <- format(Sys.time(), "%H:%M:%S")
paste("Time:", time, "|", "Running tasks:", controller$unresolved())
})
}

shinyApp(ui = ui, server = server)
```

# Example: coin flips

The example app below has an action button and two text outputs. When you click the action button, the app submits a batch of 20 tasks (simulated coin flips) to the `crew` controller. The text outputs refresh to show the current time, the number of upcoming coin flips, and running totals for heads, tails, and errors.
The example app below demonstrates a high-throughput scenario where there may be too many individual tasks to efficiently manage each one individually. The app has an action button and two text outputs. When you click the action button, the app submits a batch of 20 tasks (simulated coin flips) to the `crew` controller. The action button can submit new tasks even when existing tasks are running in the background. The text outputs refresh to show the current time, the number of upcoming coin flips, and running totals for heads, tails, and errors.

![](./figures/coins.png)

Expand Down Expand Up @@ -183,148 +331,98 @@ server <- function(input, output, session) {
shinyApp(ui = ui, server = server)
```

# Example: generative art

The simple example below has three interface elements: an action button, a plot output, and a text output. When you click the action button, a new 5-second task pushes to the `crew` controller. The plot output shows the random visualization returned from latest task.

The text output continuously refreshes to show the current time and number of tasks in progress. Watch the short video linked below to see the app in action. You will see the time tick away even as tasks run in the background. In other words, the tasks run asynchronously and do not block the app session.

[![](./figures/art.png)](https://vimeo.com/927130003)

## Prerequisites

The example app uses extended tasks, which are only available in Shiny 1.8.1.1 or above. If your installed version of Shiny is too low, you can upgrade to the development version with:

```r
remotes::install_github("rstudio/shiny")
```

## Tutorial

To begin, the app script loads Shiny.

```r
library(shiny)
```

The `run_task()` function waits 5 seconds and then generates a random [`aRtsy::canvas_squares()`](https://koenderks.github.io/aRtsy/reference/canvas_squares.html) plot.

```r
run_task <- function() {
Sys.sleep(5)
aRtsy::canvas_squares(colors = aRtsy::colorPalette("random-palette"))
}
```

The [user interface](https://shiny.rstudio.com/articles/basics.html) shows the three parts explained previously, along with HTML/CSS formatting.
# Modified example: coin flips with extended tasks

```r
ui <- fluidPage(
tags$br(),
tags$style("#status,#task{font-size:3em}"),
tags$style("#task{border:3px solid black}"),
actionButton("task", "Submit a task (5 seconds)"),
textOutput("status"),
plotOutput("result")
)
```
A self-renewing Shiny extended task can make the coin flip app more responsive. However, there may be a performance cost due to post-processing each task individually (as opposed to processing in bulk using `controller$collect()`). These are tradeoffs which may lead to different optimal decisions on a case-by-case basis. Please choose the approach that best fits your own app.

The [server](https://shiny.rstudio.com/articles/basics.html) sets up a [local process controller](https://wlandau.github.io/crew/reference/crew_controller_local.html). The controller has 4 workers, and each worker automatically shuts down if 10 seconds pass without any task assignments. The `onStop()` statement says to terminate the controller when the app session terminates.
To make the app respond immediately to each completed coin flip, first define an extended task that re-invokes itself whenever a task completes.

```r
server <- function(input, output, session) {
controller <- crew::crew_controller_local(workers = 4, seconds_idle = 10)
controller$start()
onStop(function() controller$terminate())
task <- ExtendedTask$new(function() controller$promise(mode = "one"))
observe(if (task$status() != "running") task$invoke())
```

The `task` object below is a Shiny extended task which accepts a promise object from the controller. The `crew` promise resolves when a task completes, and the `ExtendedTask` object efficiently manages a queue of such promises.^[For more on extended tasks, install the development version of Shiny and call `?shiny::ExtendedTask` to view the help file.]
^[For more on `crew` promises, visit <https://wlandau.github.io/crew/articles/promises.html>.]
Next, use `task$status()` to invalidate the text status as soon as a task completes.

```r
task <- ExtendedTask$new(function() controller$promise(mode = "one"))
output$status <- renderText({
invalidateLater(millis = 1000)
task$status() # Invalidates the reactive when the task completes.
time <- format(Sys.time(), "%H:%M:%S")
sprintf("%s Flipping %s coins.", time, controller$unresolved())
})
```

The "Submit a task (5 seconds)" button pushes a new task to the controller and enqueues a new promise to asynchronously handle the result.
Finally, trust `task$result()` to invalidate the reactive expression that collects results.

```r
observeEvent(input$task, {
controller$push(command = run_task(), data = list(run_task = run_task))
task$invoke()
})
observe({
new_flip <- task$result()$result[[1]]
flips$heads <- flips$heads + sum(new_flip)
flips$tails <- flips$tails + sum(!new_flip)
})
```

Because of the Shiny extended task and the `crew` promise, the plot output automatically refreshes almost immediately after the task completes.

```r
output$result <- renderPlot(task$result()$result[[1L]])
```

The text status periodically refreshes to show the current time and the number of tasks in progress. When you run the app, you will see the time tick away even as tasks and promises operate in the background.

```r
output$status <- renderText({
input$task
task$status()
invalidateLater(millis = 1000)
time <- format(Sys.time(), "%H:%M:%S")
paste("Time:", time, "|", "Running tasks:", controller$unresolved())
})
}
```

Finally, `shinyApp()` runs the app with the UI and server defined above.

```r
shinyApp(ui = ui, server = server)
```

## Code

See below for the complete `app.R` file.
The full app code is below:

```r
library(shiny)

run_task <- function() {
Sys.sleep(5)
aRtsy::canvas_squares(colors = aRtsy::colorPalette("random-palette"))
flip_coin <- function() {
Sys.sleep(runif(n = 1, min = 0.25, max = 2.5))
as.logical(rbinom(n = 1, size = 1, prob = 0.4))
}

ui <- fluidPage(
tags$br(),
tags$style("#status,#task{font-size:3em}"),
tags$style("#task{border:3px solid black}"),
actionButton("task", "Submit a task (5 seconds)"),
div("Is the coin fair?"),
actionButton("task", "Flip 20 coins"),
textOutput("status"),
plotOutput("result")
textOutput("outcomes")
)

server <- function(input, output, session) {
# crew controller
controller <- crew::crew_controller_local(workers = 4, seconds_idle = 10)
controller$start()
onStop(function() controller$terminate())

# extended task to get completed results from the controller

# Keep running totals of heads, tails, and task errors.
flips <- reactiveValues(heads = 0, tails = 0, errors = 0)

# Create a self-renewing extended task that collects individual
# results and invalidates reactive expressions on each one.
# Also collects errors.
task <- ExtendedTask$new(function() controller$promise(mode = "one"))
observe(if (task$status() != "running") task$invoke())

# button to submit a crew task
# Button to submit a batch of coin flips.
observeEvent(input$task, {
controller$push(command = run_task(), data = list(run_task = run_task))
task$invoke()
controller$walk(
command = flip_coin(),
iterate = list(index = seq_len(20)),
data = list(flip_coin = flip_coin)
)
})

# task result
output$result <- renderPlot(task$result()$result[[1L]])

# time and task status
# Print time and task status.
output$status <- renderText({
input$task
task$status()
invalidateLater(millis = 1000)
task$status()
time <- format(Sys.time(), "%H:%M:%S")
paste("Time:", time, "|", "Running tasks:", controller$unresolved())
sprintf("%s Flipping %s coins.", time, controller$unresolved())
})

# Print number of heads and tails.
output$outcomes <- renderText({
pattern <- "%s heads %s tails"
sprintf(pattern, flips$heads, flips$tails)
})

# Collect coin flip results.
observe({
new_flip <- task$result()$result[[1]]
flips$heads <- flips$heads + sum(new_flip)
flips$tails <- flips$tails + sum(!new_flip)
})
}

Expand Down

0 comments on commit 06c87b9

Please sign in to comment.