I have a Shiny application where I create an interactive scatterplot made of hexagons. If the user hovers over a hexagon, a hover will indicate how many points are in that data ("count: x").
I am now trying to send a list variable called "points" through the sendCustomMessage() function in Shiny. One item in this list is called "plotID". This is a character array that contains 60 ID values ("ID4", "ID68", etc).
The "points" object seems to successfully transfer into the htmlwidgets plotlyHex() object through the Shiny.addCustomMessageHandler() function. Using Chrome DevTools and the command console.log(drawPoints.plotID), I can verify that the "plotID" object becomes an array of characters in the browser. I am now trying to set this as the hoverinfo item in htmlwidgets so that when a user clicks on "Add points!" button, these 60 points will be drawn as pink dots and the user can hover over each one to obtain their ID name.
I tried to accomplish this with the hoverinfo: drawPoints.plotID command in my working example below, but this does not seem to help. Indeed, in the current code, the user can hover over the pink points, but what they see is the x coordinate, y coordinate, and some arbitrary trace value.
How can I tweak the below code so that the user will see the ID upon hovering over the superimposed pink points? Thanks for any suggestions!
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)
