CODEWITHSUNDEEP
rshinyshiny-reactivity
VKV
VKV

Reputation: 135

Update a tibble and a dropdown when a button is clicked; update the tibble when choices are made in the dropdown

I've created the Shiny app below:

library(shiny)
library(shinyWidgets)
library(tidyverse)

tbl1 <- tibble(obs = as_factor(letters[1:3]), val = -1:1)
tbl2 <- tibble(obs = as_factor(letters[1:3]), val = 0:2)

flag_outliers <- function(tbl) {
  tbl %>% mutate(is_outlier = near(val, min(val)) | near(val, max(val)))
}

ui <- fluidPage(
  column(6,
    radioButtons("tbl", "Select tibble", choices = c("tbl1", "tbl2")),
    actionButton("flag_w_func", "Flag outliers with function"),
    pickerInput(
      "user_choices", "Flag outliers yourself",
      letters[1:3], multiple = TRUE, options = pickerOptions(actionsBox = TRUE)
    )
  ),
  column(6, tableOutput("tbl_w_flags"))
)

server <- function(input, output, session) {
  tbl <- reactive(switch(input$tbl, tbl1 = tbl1, tbl2 = tbl2))
  
  tbl_w_flags <- reactive(flag_outliers(tbl())) # Not sure what this should be
  
  output$tbl_w_flags <- renderTable(tbl_w_flags())
}

shinyApp(ui, server)

This defines two tibbles, tbl1 and tbl2, and allows the user to choose one; their choice is stored in tbl in the server function. I want to create another tibble in the server function called tbl_w_flags that's tbl plus an is_outlier column.

If the user clicks on the "Flag outliers with function" button, the is_outlier column should be set using flag_outliers(). Also, the dropdown list user_choices should display check marks next to the observations that have been flagged by flag_outliers() and those observations only.

If the user checks or unchecks observations in the dropdown list, the is_outlier column should be updated appropriately - the appropriate values should be changed to TRUE or FALSE.

Thus, tbl_w_flags needs to be modified if the button is clicked or choices are made in the dropdown list, and the dropdown list needs to be modified if the button is clicked.

I don't have much Shiny experience and am struggling to figure out how to do this. Is this possible? If so, how can it be accomplished?

Upvotes: 2

Views: 53

Answers (1)

Thomas
Thomas

Reputation: 1302

I removed tbl_w_flags and directly updated tbl(), two reactive are not necessary here. I also used reactiveVal for reactive and added an updatePickerInput to also update the picker if the button is clicked

library(shiny)
library(shinyWidgets)
library(tidyverse)

tbl1 <- tibble(obs = as_factor(letters[1:3]), val = -1:1)
tbl2 <- tibble(obs = as_factor(letters[1:3]), val = 0:2)

flag_outliers <- function(tbl) {
  tbl %>% mutate(is_outlier = near(val, min(val)) | near(val, max(val)))
}

ui <- fluidPage(
  column(6,
         radioButtons("tbl", "Select tibble", choices = c("tbl1", "tbl2")),
         actionButton("flag_w_func", "Flag outliers with function"),
         pickerInput(
           "user_choices", "Flag outliers yourself",
           letters[1:3], multiple = TRUE, options = pickerOptions(actionsBox = TRUE)
         )
  ),
  column(6, tableOutput("tbl_w_flags"))
)

server <- function(input, output, session) {
  tbl <- reactiveVal()
  observe(tbl(switch(input$tbl, tbl1 = tbl1, tbl2 = tbl2)))
  
  observe(input$user_choices)
  
  observeEvent(input$flag_w_func, {
    old_tbl <- tbl()
    new_tbl <- flag_outliers(old_tbl)
    # Update reactive tbl and user_choice pickerInput
    tbl(new_tbl)
    new_choices <- new_tbl %>% filter(is_outlier) %>% pull(obs)
    updatePickerInput(session, "user_choices", selected = new_choices)
  })

  observeEvent(input$user_choices, {
    old_tbl <- tbl()
    new_tbl <- old_tbl %>% mutate(is_outlier = c(obs %in% input$user_choices))
    # Update reactive tbl()
    tbl(new_tbl)
  })
  output$tbl_w_flags <- renderTable(tbl())
}

shinyApp(ui, server)

Edit:
If you like to reset the picker whenever the tibble is changed (using the radio buttons), change your first observer to

observe({
  tbl(switch(input$tbl, tbl1 = tbl1, tbl2 = tbl2))
  updatePickerInput(session, "user_choices", selected = character(0))
})

Upvotes: 1

Related Questions