如何使用 R Shiny 中的绘图代理将文本注释添加到绘图图中

Question

在 R Shiny 中，我想在绘图图中添加文本注释，而不必重绘整个图。使用带有重布局参数的 plotlyProxy 和 plotlyproxyInvoke 似乎是正确的方法，但我无法让它工作。

当按下操作按钮时，会为多个字符生成一个身高与体重的关系图。然后，我想使用 selectizeinput 选择多个字符名称，并在图中注释它们的对应点。不幸的是，当我进行选择时，没有出现任何文本注释。

在下面的可重现示例中，重绘整个图表很好，因为只有几个点，但我的实际数据集有数千个点，所以我希望能够在不重绘的情况下进行注释。 p>

这是可重现的示例：

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

多年来我一直在同一个问题上苦苦挣扎，我希望这对你自己和其他可能在同一条船上的人有所帮助。

我不确定这是否一定是最漂亮的修复，但基本上我只能通过定义一个创建注释定义（列表）的递归列表的函数来重新布局以绘制注释。换句话说：包含定义每个所需 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)