r - 从 sendCustomMessage() 在 htmlwidgets/plotly 对象中定义悬停信息

Question

我有一个 Shiny 的应用程序，我在其中创建了一个由六边形组成的交互式散点图。如果用户将鼠标悬停在六边形上，悬停将指示该数据中有多少个点(“计数:x”)。

我现在尝试通过 Shiny 中的 sendCustomMessage() 函数发送一个名为“points”的列表变量。该列表中的一项称为“plotID”。这是一个包含 60 个 ID 值(“ID4”、“ID68”等)的字符数组。

“points”对象似乎通过 Shiny.addCustomMessageHandler() 函数成功转移到 htmlwidgetsplotlyHex() 对象中。使用 Chrome DevTools 和命令 console.log(drawPoints.plotID)，我可以验证“plotID”对象是否成为浏览器中的字符数组。我现在尝试将其设置为 htmlwidgets 中的悬停信息项，以便当用户单击“添加点!”时按钮，这 60 个点将被绘制为粉红色的点，用户可以将鼠标悬停在每个点上以获取其 ID 名称。

我尝试在下面的工作示例中使用hoverinfo:drawPoints.plotID命令来完成此操作，但这似乎没有帮助。事实上，在当前代码中，用户可以将鼠标悬停在粉红点上，但他们看到的是 x 坐标、y 坐标和一些任意跟踪值。

如何调整下面的代码，以便用户将鼠标悬停在叠加的粉红点上时看到 ID？感谢您的任何建议!

library(plotly)
library(ggplot2)
library(shiny)
library(htmlwidgets)
library(utils)
library(tidyr)
library(stats)
library(hexbin)
library(stringr)
library(dplyr)
library(shinycssloaders)
library(shinydashboard)
library(shinycssloaders)
library(Hmisc)
library(RColorBrewer)

options(spinner.color.background="#F5F5F5")
pointColor = colList = scales::seq_gradient_pal("maroon1", "maroon4", "Lab")(seq(0,1,length.out=8))[1]

dat = data.frame(ID = paste0("ID", 1:5000), A.1 = round(abs(rnorm(5000,100,70))), A.2 = round(abs(rnorm(5000,100,70))), A.3 = round(abs(rnorm(5000,100,70))), B.1 = round(abs(rnorm(5000,100,70))), B.2 = round(abs(rnorm(5000,100,70))), B.3 = round(abs(rnorm(5000,100,70))))
dat$ID = as.character(dat$ID)

dataMetrics = data.frame(ID = paste0("ID", 1:5000), logFC = rnorm(5000,0,10), PValue = runif(5000, 0, 1))

datCol <- colnames(dat)[-which(colnames(dat) %in% "ID")]
myPairs <- unique(sapply(datCol, function(x) unlist(strsplit(x,"[.]"))[1]))
myMetrics <- colnames(dataMetrics[[1]])[-which(colnames(dataMetrics[[1]]) %in% "ID")]

sidebar <- shinydashboard::dashboardSidebar(
  shinydashboard::sidebarMenu(id="tabs", shinydashboard::menuItem("Example", tabName="exPlot")
  )
)

body <- shinydashboard::dashboardBody(
shinydashboard::tabItems(
shinydashboard::tabItem(tabName = "exPlot",
  fluidRow(
    column(width = 4, 
      shinydashboard::box(width = NULL, status = "primary", title = "Add points", solidHeader = TRUE, 
      shiny::actionButton("goButton", "Add points!"))),
column(width = 8,
    shinydashboard::box(width = NULL, shinycssloaders::withSpinner(plotly::plotlyOutput("exPlot")), collapsible = FALSE, background = "black", title = "Example plot", status = "primary", solidHeader = TRUE))))))

ui <- shinydashboard::dashboardPage(
  shinydashboard::dashboardHeader(title = "Example", titleWidth = 180),
  sidebar,
  body
)

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

  fcInputMax = max(dataMetrics[["logFC"]])

  curPairSel <- eventReactive(input$goButton, {
  dataMetrics[which(dataMetrics[["PValue"]] < 0.05 & dataMetrics[["logFC"]] > 6),]})

  output$exPlot <- plotly::renderPlotly({

    xMax = max(dataMetrics[["logFC"]])
    xMin = min(dataMetrics[["logFC"]])
    yMax = -log(min(dataMetrics[["PValue"]]))
    yMin = -log(max(dataMetrics[["PValue"]]))
    fcMax = ceiling(max(exp(xMax), 1/exp(xMin)))

    x = dataMetrics[["logFC"]]
    y = -log(dataMetrics[["PValue"]])
    h = hexbin(x=x, y=y, xbins=10, shape=3, IDs=TRUE, xbnds=c(xMin, xMax), ybnds=c(yMin, yMax))
    hexdf = data.frame (hcell2xy (h),  hexID = h@cell, counts = h@count)
    attr(hexdf, "cID") <- h@cID

    # By default, groups into six equal-sized bins
    hexdf$countColor <- cut2(hexdf$counts, g=6, oneval=FALSE)
    hexdf$countColor2 <- as.factor(unlist(lapply(as.character(hexdf$countColor), function(x) substring(strsplit(gsub(" ", "", x, fixed = TRUE), ",")[[1]][1], 2))))
    hexdf$countColor2 <- factor(hexdf$countColor2, levels = as.character(sort(as.numeric(levels(hexdf$countColor2)))))

    for (i in 1:(length(levels(hexdf$countColor2))-1)){
      levels(hexdf$countColor2)[i] <- paste0(levels(hexdf$countColor2)[i],"-",levels(hexdf$countColor2)[i+1])
    }
    levels(hexdf$countColor2)[length(levels(hexdf$countColor2))] <- paste0(levels(hexdf$countColor2)[length(levels(hexdf$countColor2))], "+")

    my_breaks = levels(hexdf$countColor2)
    clrs <- brewer.pal(length(my_breaks)+3, "Purples")
    clrs <- clrs[3:length(clrs)]

    p <- reactive(ggplot2::ggplot(hexdf, aes(x=x, y=y, hexID=hexID, counts=counts, fill=countColor2)) + geom_hex(stat="identity") + scale_fill_manual(labels = as.character(my_breaks), values = rev(clrs), name = "Count") + theme(axis.text=element_text(size=15), axis.title=element_text(size=15), legend.title=element_text(size=15), legend.text=element_text(size=15)) + coord_cartesian(xlim = c(xMin, xMax), ylim = c(yMin, yMax)) + xlab("logFC") + ylab(paste0("-log10(", "PValue", ")")))

    gP <- eventReactive(p(), {
      gP <- plotly::ggplotly(p(), height = 400)
      for (i in 1:(length(gP$x$data)-1)){
        info <- gP$x$data[i][[1]]$text
        info2 <- strsplit(info,"[<br/>]")
        myIndex <- which(startsWith(info2[[1]], "counts:"))
        gP$x$data[i][[1]]$text <- info2[[1]][myIndex]
      }
      gP$x$data[length(gP$x$data)][[1]]$text <- NULL
      gP
    })

    plotlyHex <- reactive(gP() %>% config(displayModeBar = F))

    # Use onRender() function to draw x and y values of selected rows as orange point
    plotlyHex() %>% onRender("
       function(el, x, data) {
       Shiny.addCustomMessageHandler('points', function(drawPoints) {
console.log(drawPoints.plotID)
       var Traces = [];
       var trace = {
       x: drawPoints.plotX,
       y: drawPoints.plotY,
       hoverinfo: drawPoints.plotID,
       mode: 'markers',
       marker: {
       color: '#FF34B3',
       size: drawPoints.pointSize,
       },
       showlegend: false
       };
       Traces.push(trace);
       Plotly.addTraces(el.id, Traces);
       });}")
  })

  observe({

    plotX <- curPairSel()[["logFC"]]
    plotY <- -log(curPairSel()[["PValue"]])
    plotID <- curPairSel()[["ID"]]
    pointSize <- 8

    # Send x and y values of selected row into onRender() function
    session$sendCustomMessage(type = "points", message=list(plotX=plotX, plotY=plotY, plotID=plotID, pointSize = pointSize))
  })

  }  

shiny::shinyApp(ui = ui, server = server)

Answer 1

我有一个包含一些悬停信息的 3D 绘图，我对悬停的调用如下所示:

hoverinfo = 'text',
text = ~paste(
'</br> Time(sec): ', T,
'</br> Directly Measured Volume: ', X,
'</br> Flow: ', Y,
'</br> CO2: ', Z),

其中“字符串:”是紧邻数据框中名为 T、X、Y 和 Z 的变量之前显示在悬停框中的所有文本。

就你而言，我认为我们正在讨论这个:

hoverinfo: 'text',
text = ~paste(
'</br> ID: ', drawPoints.plotID),

尝试一下，让我知道它是否有效。