plotly shiny 反應值“未找到錯誤 function”

Question

我正在開發一個 Shiny 應用程序，我想在其中深入了解具有多個級別的 plot。 我很難讓 reactiveValues function 工作，所以我可以更新 plot。 如果我設置selections <- reactiveVal()我沒有收到任何錯誤，但是當我點擊 plot 時沒有任何反應。 另一方面，如果我使用selections <- reactiveValues()我會收到錯誤“選擇錯誤：找不到 function “選擇””

根據閱讀其他帖子，似乎我的問題可能與我如何將更新設置為變量有關，但我不太清楚如何修復它/問題在我的代碼中的位置。

這是一個可重現的示例：

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

以下內容應該對您有所幫助。

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)