我有一个Shiny应用程序，在其中创建了一个由六边形组成的交互式散点图。如果用户将鼠标悬停在六边形上，则悬停将指示该数据中有多少个点（“计数：x”）。
我现在正尝试通过Shiny中的sendCustomMessage（）函数发送一个名为“ points”的列表变量。该列表中的一项称为“ plotID”。这是一个字符数组，包含60个ID值（“ ID4”，“ ID68”等）。
“点”对象似乎已通过Shiny.addCustomMessageHandler（）函数成功转移到了htmlwidgets plotlyHex（）对象中。使用Chrome DevTools和命令console.log（drawPoints.plotID），我可以验证“ plotID”对象是否成为浏览器中的字符数组。我现在正在尝试将此设置为htmlwidgets中的hoverinfo项，以便当用户单击“添加点！”时按钮，这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)
答案 0 :(得分：0)
我有一个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),
尝试一下，让我知道它是否有效。