plotly shiny 反应值“未找到错误 function”

Question

I'm working on a Shiny app in which I want to drill down into a plot with multiple levels. I am having difficulty getting the reactiveValues function to work so I can update the plot. If I set selections <- reactiveVal() I get no errors, but nothing happens when I click on the plot. On the other hand, if I use selections <- reactiveValues() I get the error "Error in selections: could not find function "selection""

Based on reading other posts, it seems like my problem is likely having to do with how exactly I set the update to the variable but I can't quite figure out how to fix it / where the issue is in my code.

Here is a reproducible example:

library(bs4Dash)
library(plotly)
library(tidyverse)

fake_data_wide <- tibble(level_1 = rep(c("A", "B", "C"), each = 50),
                         level_2 = rep(c(c("1", "2"), c("3", "4"), c("5", "6")), each = 25),
                         level_3 = c(rep("a", 40), rep("b", 10), rep("c", 30), rep("d", 20),
                                     rep("e", 20), rep("f", 30)),
                         sent = rnorm(150),
                         number = rpois(150, lambda = 1)) 


fake_data_long <- fake_data_wide %>% 
  pivot_longer(level_1:level_3, names_to = "level_of_specificity",
               values_to = "group_name")

one_level_down <- fake_data_wide %>% 
  select(group_name = level_1, 
         one_down = level_2) %>% 
  bind_rows(fake_data_wide %>% 
              select(group_name = level_2,
                     one_down = level_3)) %>% distinct()



ui <- dashboardPage(
  header = dashboardHeader(title = "test"),
  sidebar = dashboardSidebar(),
  body = dashboardBody(fluidRow(box(plotlyOutput("drill_down_plot"),
                                    id = "test_box"),
                                uiOutput("back")))
)


server <- function(input, output){
  
  selections <- reactiveValues()
  
  observeEvent(event_data("plotly_selected", source = "drill_down_plot"), {
    new <- event_data("plotly_selected")$customdata[[1]]
    old <- selections()
    selections(c(old, new))
  })
  
  output$drill_down_plot <- renderPlotly({
    
    if(length(selections() == 0)){
      fake_data_long %>% 
        filter(level_of_specificity == "level_1") %>% 
        group_by(group_name) %>% 
        summarise(g_sent_mean = mean(sent),
                  g_total_mean = mean(number)) %>% ungroup() %>% 
        plot_ly(x = ~g_sent_mean, y = ~g_total_mean,
                size = ~g_total_mean, customdata = ~group_name)
    } else {
      
      one_level_down %>% 
        filter(group_name %in% selections_test) %>% 
        mutate(group_name = one_down) %>% select(-one_down) %>% 
        inner_join(fake_data_long) %>% 
        group_by(group_name) %>% 
        summarise(g_sent_mean = mean(sent),
                  g_total_mean = mean(number)) %>% ungroup() %>% 
        plot_ly(x = ~g_sent_mean, y = ~g_total_mean,
                size = ~g_total_mean, customdata = ~group_name)
      
    }
    
    
    
  })
  
  output$back <- renderUI({
    if (length(selections())) 
      actionButton("clear", "Back", icon("chevron-left"))
  })
  
  
}

shinyApp(ui = ui, server = server)

Answer 1

The following should help you.

library(bs4Dash)
library(plotly)
library(tidyverse)

fake_data_wide <- tibble(level_1 = rep(c("A", "B", "C"), each = 50),
                         level_2 = rep(c(c("1", "2"), c("3", "4"), c("5", "6")), each = 25),
                         level_3 = c(rep("a", 40), rep("b", 10), rep("c", 30), rep("d", 20),
                                     rep("e", 20), rep("f", 30)),
                         sent = rnorm(150),
                         number = rpois(150, lambda = 1)) 


fake_data_long <- fake_data_wide %>% 
  pivot_longer(level_1:level_3, names_to = "level_of_specificity",
               values_to = "group_name")

one_level_down <- fake_data_wide %>% 
  dplyr::select(group_name = level_1, one_down = level_2) %>% 
  bind_rows(fake_data_wide %>% 
              dplyr::select(group_name = level_2, one_down = level_3)) %>% distinct()



ui <- dashboardPage(
  header = dashboardHeader(title = "test"),
  sidebar = dashboardSidebar(),
  body = dashboardBody(fluidRow(box(plotlyOutput("drill_down_plot"),
                                    id = "test_box"),
                                uiOutput("back")))
)


server <- function(input, output){
  
  my <- reactiveValues(selections=NULL)
  
  observeEvent(event_data("plotly_selected", source = "drill_down_plot", priority = "event"), {
    my$selections <- event_data("plotly_selected", priority = "event")$customdata[[1]]
    old <- my$selections
    #print(my$selections) # c(old, new)
  }, ignoreNULL = FALSE)
  
  output$drill_down_plot <- renderPlotly({
    
    select_data <- event_data("plotly_selected", priority   = "event")
    my$selections <- select_data$customdata
    print(select_data)
    if (is.null(select_data)) {
      print("hello1")
      df1 <- fake_data_long %>% 
        dplyr::filter(level_of_specificity == "level_1") %>% 
        group_by(group_name) %>% 
        dplyr::summarise(g_sent_mean = mean(sent),
                  g_total_mean = mean(number)) %>% ungroup() # %>% 
        # plot_ly(x = ~g_sent_mean, y = ~g_total_mean,
        #         size = ~g_total_mean, customdata = ~group_name)
    } else {
      print("hello2")
      df1 <- one_level_down %>% 
        dplyr::filter(group_name %in% select_data$customdata) %>% 
        mutate(group_name = one_down) %>% dplyr::select(-one_down) %>% 
        inner_join(fake_data_long) %>% 
        group_by(group_name) %>% 
        dplyr::summarise(g_sent_mean = mean(sent),
                  g_total_mean = mean(number)) %>% ungroup() #%>% 
        # plot_ly(x = ~g_sent_mean, y = ~g_total_mean,
        #         size = ~g_total_mean, customdata = ~group_name)
      
    }
    plot_ly(df1, x = ~g_sent_mean, y = ~g_total_mean,
            size = ~g_total_mean, customdata = ~group_name) %>% layout(dragmode = "lasso")
    
  })
  
  output$back <- renderUI({
    if (!is.null(my$selections)) actionButton("clear", "Back", icon("chevron-left"))
  })
  
  
}

shinyApp(ui = ui, server = server)