如何使用 R Z3E751ABE1B5D0235C68CF279ADZ7A 中的 plotly 代理向 plotly 圖形添加文本注釋

Question

在 R Shiny 中，我想在 plotly 圖形中添加文本注釋，而無需重新繪制整個圖形。 使用帶有重布局參數的 plotlyProxy 和 plotlyproxyInvoke 似乎是 go 的正確方法，但我無法讓它工作。

當按下操作按鈕時，會為多個字符生成一個身高與體重的關系圖。 然后我想使用 selectizeinput 成為 select 多個字符名稱，並在 plot 中注釋它們的對應點。 不幸的是，當我進行選擇時，沒有出現任何文本注釋。

在下面的可重復示例中，重繪整個圖表很好，因為只有幾個點，但我的實際數據集有數千個點，所以我希望能夠在不重繪重繪的情況下進行注釋。

這是可重現的示例：

library(shiny)
library(shinyjs)
library(plotly)

ui <- fluidPage(
sidebarLayout(
    sidebarPanel(
        radioButtons(inputId = "Race", label = "Race", choices = c("Humans", "Goblins"), selected = "Humans"),
        actionButton(inputId = "Go", label = "Plot")
    ),
    mainPanel(
       plotlyOutput(outputId = "Height_Weight_plot"),
       selectizeInput(inputId = "Names", label = "Search for characters", choices = NULL, multiple = TRUE)
    )
)
)

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

character_data <- eventReactive(input$Go,{
    if(input$Race == "Humans"){
        data.frame(
            Name = c("Arthur", "Rodrick", "Elaine", "Katherine", "Gunther", "Samuel", "Marcus", "Selene"),
            Role = c("Nobleman", "Soldier", "Soldier", "Priestess", "Mage", "Squire", "Merchant", "Witch"),
            Sex = c("M", "M", "F", "F", "M", "M", "M", "F"),
            Age = c(39, 41, 29, 46, 55, 17, 42, 40),
            Height = c(6.00, 5.10, 5.80, 5.20, 6.30, 5.10, 5.40, 6.20),
            Weight = c(160, 165, 154, 129, 171, 144, 131, 144)
        )
    }else if(input$Race == "Goblins"){
        data.frame(
            Name = c("Grog", "Dirk", "Kane", "Yilde", "Moldred", "Vizir", "Igret", "Baelon"),
            Role = c("Pirate", "Pirate", "Pirate", "Bandit", "Merchant", "Bandit", "Merchant", "Shaman"),
            Sex = c("M", "M", "M", "F", "F", "M", "F", "M"),
            Age = c(178, 251, 118, 490, 231, 171, 211, 621),
            Height = c(3.80, 3.50, 3.10, 4.00, 4.10, 3.70, 3.20, 4.00),
            Weight = c(100, 96, 88, 113, 92, 101, 94, 112)
        )
        
    }
},ignoreNULL = T)

observe({
    updateSelectizeInput(session, "Names", choices = character_data()$Name)
})

output$Height_Weight_plot <- renderPlotly({
    p <- plot_ly(character_data(), 
                 x = ~Height, 
                 y = ~Weight, 
                 type = "scatter",  
                 mode = "markers", 
                 hoverinfo = "text",
                 hovertext = ~paste("Name: ",Name, 
                                    "\nRole: ",Role,
                                    "\nAge: ",Age,
                                    "\nHeight: ",Height,
                                    "\nWight: ",Weight))
    print(p)
})

observe({
    if(length(input$Names) != 0){
        character_data_sub <- character_data() %>% dplyr::filter(Name %in% input$Names)
        plotlyProxy("Height_Weight_plot", session) %>%
            plotlyProxyInvoke(
                "relayout",
                list(
                    annotations = list(x = character_data_sub$Height, 
                                       y = character_data_sub$Weight, 
                                       text = character_data_sub$Name,
                                       xref = "x", 
                                       yref = "y", 
                                       showarrow = T, 
                                       arrowhead = 7, 
                                       ax = 20, 
                                       ay = -40)
                )
            )
    }
})

}

# Run the application 
shinyApp(ui = ui, server = server)

Answer 1

我多年來一直在同一個問題上苦苦掙扎，我希望這對你自己和可能在同一條船上的其他人有所幫助。

我不確定這是否一定是最漂亮的修復，但基本上我只能通過定義一個創建注釋定義（列表）的遞歸列表的 function 來重新布局以繪制注釋。 換句話說：包含定義每個所需 Plotly 注釋的各個單獨列表的列表（每個都類似於 Python 字典）。

希望這一切都說得通！

    library(shiny)
    library(shinyjs)
    library(plotly)
    
    ui <- fluidPage(
      sidebarLayout(
        sidebarPanel(
          radioButtons(inputId = "Race", label = "Race", choices = c("Humans", "Goblins"), selected = "Humans"),
          actionButton(inputId = "Go", label = "Plot")
        ),
        mainPanel(
          plotlyOutput(outputId = "Height_Weight_plot"),
          selectizeInput(inputId = "Names", label = "Search for characters", choices = NULL, multiple = TRUE)
        )
      )
    )
    
    server <- function(input, output, session) {
      
      character_data <- eventReactive(input$Go,{
        if(input$Race == "Humans"){
          data.frame(
            Name = c("Arthur", "Rodrick", "Elaine", "Katherine", "Gunther", "Samuel", "Marcus", "Selene"),
            Role = c("Nobleman", "Soldier", "Soldier", "Priestess", "Mage", "Squire", "Merchant", "Witch"),
            Sex = c("M", "M", "F", "F", "M", "M", "M", "F"),
            Age = c(39, 41, 29, 46, 55, 17, 42, 40),
            Height = c(6.00, 5.10, 5.80, 5.20, 6.30, 5.10, 5.40, 6.20),
            Weight = c(160, 165, 154, 129, 171, 144, 131, 144)
          )
        }else if(input$Race == "Goblins"){
          data.frame(
            Name = c("Grog", "Dirk", "Kane", "Yilde", "Moldred", "Vizir", "Igret", "Baelon"),
            Role = c("Pirate", "Pirate", "Pirate", "Bandit", "Merchant", "Bandit", "Merchant", "Shaman"),
            Sex = c("M", "M", "M", "F", "F", "M", "F", "M"),
            Age = c(178, 251, 118, 490, 231, 171, 211, 621),
            Height = c(3.80, 3.50, 3.10, 4.00, 4.10, 3.70, 3.20, 4.00),
            Weight = c(100, 96, 88, 113, 92, 101, 94, 112)
          )
          
        }
      },ignoreNULL = T)
      
      observe({
        updateSelectizeInput(session, "Names", choices = character_data()$Name)
      })
      
      ##function that creates plotly dictionary object for single annotation
      listify_func <- function(x, y, text){
        return(list(
          x = x,
          y = y,
          text = as.character(text),
          xref = "x",
          yref = "y",
          showarrow = TRUE,
          arrowhead = 7,
          arrowcolor = "#ff9900",
          font = list(color = "#000000", size = 10),
          ax = runif(1, 1, 90),
          ay = -runif(1, 1, 90),
          bgcolor = "#f5f5f5",
          bordercolor = "#b3b3b3"
        ))
      }
      
      ##creating reactive object containing the subsetted data:
      highlighted <- eventReactive(input$Names,{
        character_data_sub <- character_data() %>% dplyr::filter(Name %in% input$Names)
      })
      
      ##creating a recursive list of annotation lists for selected genes 
      annotation_list <- reactiveValues(data = NULL)
      observeEvent(input$Names,{
        x <- highlighted()$Height
        y <- highlighted()$Weight
        text <- highlighted()$Name
        ##create dataframe with relative x, y and text values to create 
        ##annotations:
        df <- data.frame(x = x, y = y, text = text)
        ##create matrix of lists defining each annotation
        ma <- mapply(listify_func, df$x, df$y, df$text)
        if(length(ma) > 0){
          ##convert matrix to list of lists:
          annotation_list$data <- lapply(seq_len(ncol(ma)), function(i) ma[,i])
        }
      })
      ##if nothing is selected, clear recursive list (i.e. remove annotations):
      observe({
        if(is.null(input$Names)){
          annotation_list$data <- list()
        }
      })
      
      output$Height_Weight_plot <- renderPlotly({
        p <- plot_ly(character_data(), 
                     x = ~Height, 
                     y = ~Weight, 
                     type = "scatter",  
                     mode = "markers", 
                     hoverinfo = "text",
                     hovertext = ~paste("Name: ",Name, 
                                        "\nRole: ",Role,
                                        "\nAge: ",Age,
                                        "\nHeight: ",Height,
                                        "\nWight: ",Weight))
      })
      
      
      ##proxy updating recursive list for annotations
      observeEvent(annotation_list$data,{
            plotlyProxy("Height_Weight_plot", session) %>%
              plotlyProxyInvoke(
                "relayout",
                list(annotations = annotation_list$data)
              )
      })
      
    
    }
    
    # Run the application 
    shinyApp(ui = ui, server = server)