如何在 R 中为 plotly boxplots 自定义悬停文本

Posted 2023-02-14

【中文标题】如何在 R 中为 plotly boxplots 自定义悬停文本

【英文标题】：How to customize hover text for plotly boxplots in R

【发布时间】：2018-09-04 20:01:55

【问题描述】：

我了解如何在plotly 中自定义散点图的悬停文本，但箱形图不接受“文本”属性。 Warning message: 'box' objects don't have these attributes: 'text'。我有超过 300 个 x 轴变量，并且在两组（A 或 B）中有编号的样本（1-50），我想在同一个箱线图中一起绘制，然后我想区分样本数和将光标移动到异常值上时通过悬停文本进行分组。我想要我的自定义数据标签而不是自动四分位数标签。 plotly boxplots 有可能吗？

library(plotly) 
library(magrittr)

plot_ly(melt.s.data, 
          x = ~variable, 
          y = ~value,
          type = 'box', 
          text = ~paste("Sample number: ", Sample_number, 
                       '<br>Group:', Group)) %>% 
        layout(title = "Individual distributions at each x")

这是一些仅显示 5 x 变量的示例数据（但当外推到我的 300 时，代码应该可以工作）...

#sample data
set.seed(456)
#Group A
sample.data_a <- data.frame(Class = "red", Group = "A",
                            Sample_number = seq(1,50,by=1), 
                            x1= rnorm(50,mean=0, sd=.5), 
                            x2= rnorm(50,mean=0.5, sd=1.5), 
                            x3= rnorm(50,mean=5, sd=.1), 
                            x4= rnorm(50,mean=0, sd=3.5),
                            x5= rnorm(50,mean=-6, sd=.005))
#Group B
sample.data_b <- data.frame(Class = "red", Group = "B",
                            Sample_number = seq(1,50,by=1), 
                            x1= rnorm(50,mean=0, sd=5.5), 
                            x2= rnorm(50,mean=0.5, sd=7.5), 
                            x3= rnorm(50,mean=5, sd=.01), 
                            x4= rnorm(50,mean=0, sd=.5),
                            x5= rnorm(50,mean=-6, sd=2.05))

#row Bind groups 
sample.data <- rbind(sample.data_a, sample.data_b)

#melting data to have a more graphable format
library(reshape2)
melt.s.data<-melt(sample.data, id.vars=c("Class", "Group","Sample_number"))

以下是类似的问题：

Here 似乎不可能。 这个question类似，只是想添加相关的四分位信息。 而这个question 只是情节箱线图中的一个点。

【问题讨论】：

请提供一个可重现的例子。

@MLavoie 我为可重现的示例添加了数据。

andemexoax，您接受了我的回答，谢谢。请参阅my blog 以获得另一个更好的解决方案。 （更好，因为它确保工具提示永远不会超出情节）。

【参考方案1】：

Shiny 可以做到。

library(plotly)
library(shiny)
library(htmlwidgets)

# Prepare data ----
set.seed(456)
#Group A
sample.data_a <- data.frame(Class = "red", Group = "A",
                            Sample_number = seq(1,50,by=1), 
                            x1= rnorm(50,mean=0, sd=.5), 
                            x2= rnorm(50,mean=0.5, sd=1.5), 
                            x3= rnorm(50,mean=5, sd=.1), 
                            x4= rnorm(50,mean=0, sd=3.5),
                            x5= rnorm(50,mean=-6, sd=.005))
#Group B
sample.data_b <- data.frame(Class = "red", Group = "B",
                            Sample_number = seq(1,50,by=1), 
                            x1= rnorm(50,mean=0, sd=5.5), 
                            x2= rnorm(50,mean=0.5, sd=7.5), 
                            x3= rnorm(50,mean=5, sd=.01), 
                            x4= rnorm(50,mean=0, sd=.5),
                            x5= rnorm(50,mean=-6, sd=2.05))
#row Bind groups 
sample.data <- rbind(sample.data_a, sample.data_b)
#melting data to have a more graphable format
melt.s.data <- reshape2::melt(sample.data, 
                              id.vars=c("Class", "Group", "Sample_number"))

# Plotly on hover event ----
addHoverBehavior <- c(
  "function(el, x)",
  "  el.on('plotly_hover', function(data) ",
  "    if(data.points.length==1)",
  "      $('.hovertext').hide();",
  "      Shiny.setInputValue('hovering', true);",
  "      var d = data.points[0];",
  "      Shiny.setInputValue('left_px', d.xaxis.d2p(d.x) + d.xaxis._offset);",
  "      Shiny.setInputValue('top_px', d.yaxis.l2p(d.y) + d.yaxis._offset);",
  "      Shiny.setInputValue('dy', d.y);",
  "      Shiny.setInputValue('dtext', d.text);",
  "    ",
  "  );",
  "  el.on('plotly_unhover', function(data) ",
  "    Shiny.setInputValue('hovering', false);",
  "  );",
  "")

# Shiny app ----
ui <- fluidPage(
  tags$head(
    # style for the tooltip with an arrow (http://www.cssarrowplease.com/)
    tags$style("
               .arrow_box 
                    position: absolute;
                  pointer-events: none;
                  z-index: 100;
                  white-space: nowrap;
                  background: CornflowerBlue;
                  color: white;
                  font-size: 13px;
                  border: 1px solid;
                  border-color: CornflowerBlue;
                  border-radius: 1px;
               
               .arrow_box:after, .arrow_box:before 
                  right: 100%;
                  top: 50%;
                  border: solid transparent;
                  content: ' ';
                  height: 0;
                  width: 0;
                  position: absolute;
                  pointer-events: none;
               
               .arrow_box:after 
                  border-color: rgba(136,183,213,0);
                  border-right-color: CornflowerBlue;
                  border-width: 4px;
                  margin-top: -4px;
               
               .arrow_box:before 
                  border-color: rgba(194,225,245,0);
                  border-right-color: CornflowerBlue;
                  border-width: 10px;
                  margin-top: -10px;
               ")
  ),
  div(
    style = "position:relative",
    plotlyOutput("myplot"),
    uiOutput("hover_info")
  )
)

server <- function(input, output)
  output$myplot <- renderPlotly(
    plot_ly(melt.s.data, 
            type = "box", 
            x = ~variable, y = ~value, 
            text = paste0("<b> group: </b>", melt.s.data$Group, "<br/>",
                          "<b> sample: </b>", melt.s.data$Sample_number, "<br/>"),
            hoverinfo = "y") %>%
      onRender(addHoverBehavior)
  )
  output$hover_info <- renderUI(
    if(isTRUE(input[["hovering"]]))
      style <- paste0("left: ", input[["left_px"]] + 4 + 5, "px;", # 4 = border-width after
                      "top: ", input[["top_px"]] - 24 - 2 - 1, "px;") # 24 = line-height/2 * number of lines; 2 = padding; 1 = border thickness
      div(
        class = "arrow_box", style = style,
        p(HTML(input$dtext, 
               "<b> value: </b>", formatC(input$dy)), 
          style="margin: 0; padding: 2px; line-height: 16px;")
      )
    
  )


shinyApp(ui = ui, server = server)

【参考方案2】：

一个可能的解决方案可能是使用 ggplot2 包并向您的箱线图添加一个不可见的散点图：

library(ggplot2)
library(plotly)

gg_box <- melt.s.data %>%
  ggplot(aes(x=variable, y=value, text=paste("Group:",Group, "\n",
                                            "Class:", Class))) +
  geom_boxplot()+

  #invisible layer of points
  geom_point(alpha = 0)

gg_box %>%
  ggplotly() 

您需要稍微玩一下光标才能看到其他标签。