Task Button

#| standalone: true
#| components: [viewer]
#| viewerHeight: 200

library(bslib)
library(shiny)
library(ggplot2)

ui <- page_fluid(
  layout_column_wrap(
    card(
      selectizeInput(
        inputId = "predictors",
        label = "Choose predictors",
        choices = c("log(carat)", "color", "cut", "clarity"),
        selected = "log(carat)",
        multiple = TRUE
      ),
      input_task_button("fit_model", "Fit model"), 
    ),
    value_box(
      title = "Mean absolute error",
      value = textOutput("mae"),
      theme = "purple"
    )
  )
)

server <- function(input, output, session) {

  fit <- eventReactive( 
    input$fit_model, 
    ignoreNULL = FALSE, 
    { 
      Sys.sleep(5)  # Make this artificially slow 
      formula <- 
        formula( 
          paste0("log(price) ~ ", paste0(input$predictors, collapse = " + ")) 
        ) 

      lm(formula, data = diamonds) 
    } 
  ) 

  output$mae <- renderText({
    fit() |>
      broom::augment() |>
      yardstick::mae(truth = `log(price)`, estimate = .fitted) |>
      dplyr::pull(.estimate)
  })
}

shinyApp(ui, server)
library(bslib)
library(shiny)
library(ggplot2)

ui <- page_fluid(
  layout_column_wrap(
    card(
      selectizeInput(
        inputId = "predictors",
        label = "Choose predictors",
        choices = c("log(carat)", "color", "cut", "clarity"),
        selected = "log(carat)",
        multiple = TRUE
      ),
      input_task_button("fit_model", "Fit model"), 
    ),
    value_box(
      title = "Mean absolute error",
      value = textOutput("mae"),
      theme = "purple"
    )
  )
)

server <- function(input, output, session) {

  fit <- eventReactive( 
    input$fit_model, 
    ignoreNULL = FALSE, 
    { 
      Sys.sleep(5)  # Make this artificially slow 
      formula <- 
        formula( 
          paste0("log(price) ~ ", paste0(input$predictors, collapse = " + ")) 
        ) 

      lm(formula, data = diamonds) 
    } 
  ) 

  output$mae <- renderText({
    fit() |>
      broom::augment() |>
      yardstick::mae(truth = `log(price)`, estimate = .fitted) |>
      dplyr::pull(.estimate)
  })
}

shinyApp(ui, server)
No matching items

Relevant Functions

  • input_task_button
    input_task_button(id, label, ..., icon = NULL, label_busy = "Processing...", icon_busy = rlang::missing_arg(), type = "primary", auto_reset = TRUE)

  • eventReactive
    eventReactive(eventExpr, valueExpr, event.env = parent.frame(), event.quoted = FALSE, value.env = parent.frame(), value.quoted = FALSE, ..., label = NULL, domain = getDefaultReactiveDomain(), ignoreNULL = TRUE, ignoreInit = FALSE)

No matching items

Details

Use an input task button to launch longer-running operations. An input task button is very similar to an action button, except it prevents the user from clicking the button when its operation is already in progress.

To add an input task button to your app:

  1. Add input_task_button(), from the bslib package, to the UI of your app. Where you call this function will determine where the input task button will appear within the app’s layout.

  2. Specify the id and label arguments of input_task_button() to define the identifier and label of the task button.

  3. Optionally, use input_task_button()’s other arguments to control the appearance and behavior of the task button (e.g., label_busy controls the label of the button while it is busy).

The value of an input component is accessible as a reactive value within the server() function. The server value of an input task button is an integer of class "shinyActionButtonValue". See the function reference for more information.

  1. Use bindEvent(), eventReactive(), or observeEvent() to trigger actions using a task button.

Variations

Non-blocking task

You’ll sometimes want to perform a long-running operation in your app. Ordinarily, performing a long-running operation in a reactive context will block the rest of your application from running until the operation is done. You can use an ExtendedTask to keep your app responsive during a long operation.

For example, in the sample app below, the “Fit model” task button fits a model (artificially) slowly. In an ordinary reactive context, this would prevent the rest of the app from running, including preventing the user from hiding and showing the data table. By creating an ExtendedTask, however, the model fitting does not block the rest of the app, and the user can hide/show the data table while the model fitting operation runs. For more information, see Non-blocking operations.

#| standalone: true
#| components: [viewer]
#| viewerHeight: 300

library(bslib)
library(shiny)
library(ggplot2)
library(future)
library(promises)
library(reactable)
future::plan(multisession)

ui <- page_sidebar(
  sidebar = sidebar(
    selectizeInput(
      inputId = "predictors",
      label = "Choose predictors",
      choices = c("log(carat)", "color", "cut", "clarity"),
      selected = "carat",
      multiple = TRUE
    ),
    input_task_button("button_fit", "Fit model"), 
    input_switch("show_data", "Show data", value = TRUE)
  ),
  value_box(
    title = "Mean absolute error",
    value = textOutput("mae"),
    theme = "purple"
  ),
  reactableOutput("diamonds_table")
)

server <- function(input, output, session) {

  fit <- ExtendedTask$new(function(predictors) { 
    future_promise({ 
      Sys.sleep(5) 
      formula <- 
        formula(paste0("log(price) ~ ", paste0(predictors, collapse = " + "))) 

      lm(formula, data = diamonds) 
    }) 
  }) |> 
    bind_task_button("button_fit") 

  observeEvent(input$button_fit, { 
    fit$invoke(input$predictors) 
  }) 

  output$mae <- renderText({
    fit$result() |>
      broom::augment() |>
      yardstick::mae(truth = `log(price)`, estimate = .fitted) |>
      dplyr::pull(.estimate)
  })

  output$diamonds_table <- renderReactable({
    if (input$show_data) {
      reactable(diamonds, searchable = TRUE)
    }
  })
}

shinyApp(ui, server)
library(bslib)
library(shiny)
library(ggplot2)
library(future)
library(promises)
library(reactable)
future::plan(multisession)

ui <- page_sidebar(
  sidebar = sidebar(
    selectizeInput(
      inputId = "predictors",
      label = "Choose predictors",
      choices = c("log(carat)", "color", "cut", "clarity"),
      selected = "carat",
      multiple = TRUE
    ),
    input_task_button("button_fit", "Fit model"), 
    input_switch("show_data", "Show data", value = TRUE)
  ),
  value_box(
    title = "Mean absolute error",
    value = textOutput("mae"),
    theme = "purple"
  ),
  reactableOutput("diamonds_table")
)

server <- function(input, output, session) {

  fit <- ExtendedTask$new(function(predictors) { 
    future_promise({ 
      Sys.sleep(5) 
      formula <- 
        formula(paste0("log(price) ~ ", paste0(predictors, collapse = " + "))) 

      lm(formula, data = diamonds) 
    }) 
  }) |> 
    bind_task_button("button_fit") 

  observeEvent(input$button_fit, { 
    fit$invoke(input$predictors) 
  }) 

  output$mae <- renderText({
    fit$result() |>
      broom::augment() |>
      yardstick::mae(truth = `log(price)`, estimate = .fitted) |>
      dplyr::pull(.estimate)
  })

  output$diamonds_table <- renderReactable({
    if (input$show_data) {
      reactable(diamonds, searchable = TRUE)
    }
  })
}

shinyApp(ui, server)
No matching items