Определите hoverinfo в объекте htmlwidgets / plotly из sendCustomMessage () - PullRequest
Новая
       91

Определите hoverinfo в объекте htmlwidgets / plotly из sendCustomMessage ()

0 голосов
/ 21 октября 2018

У меня есть приложение Shiny, где я создаю интерактивную диаграмму рассеяния из шестиугольников.Если пользователь наводит указатель мыши на шестиугольник, указатель будет указывать, сколько точек содержится в этих данных («count: x»).

Я сейчас пытаюсь отправить переменную списка с именем "points" через функцию sendCustomMessage () в Shiny.Один элемент в этом списке называется «plotID».Это массив символов, содержащий 60 значений идентификаторов («ID4», «ID68» и т. Д.).

Кажется, что объект «points» успешно перенесен в объект plotlyHex () htmlwidgets через Shiny.addCustomMessageHandler () функция.Используя Chrome DevTools и команду console.log (drawPoints.plotID), я могу убедиться, что объект plotID становится массивом символов в браузере.Сейчас я пытаюсь установить это как элемент hoverinfo в htmlwidgets, чтобы, когда пользователь нажимал «Добавить точки!»Кнопка, эти 60 точек будут нарисованы в виде розовых точек, и пользователь может навести курсор на каждую из них, чтобы получить свое имя.

Я попытался сделать это с помощью команды hoverinfo: drawPoints.plotID в моем рабочем примере ниже,но это, похоже, не помогает.Действительно, в текущем коде пользователь может наводить курсор на розовые точки, но они видят координату x, координату y и некоторое произвольное значение трассировки.

Как настроить код ниже, чтобыпользователь увидит идентификатор при наведении на наложенные розовые точки?Спасибо за любые предложения! 

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)

1 Ответ

0 голосов
/ 29 октября 2018

У меня есть 3D-график, на котором есть некоторая информация о наведении, и мой вызов hover выглядит следующим образом: 

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),

Попробуйте и дайте мне знать, если это работает.

...