在单个图中获取 geom_hex 中的观测值 (Shiny)

我正在尝试创建一个十六进制的交互式图，用户可以单击给定的十六进制，并接收分组在该单击的十六进制中的原始数据帧的所有观察结果的列表。

下面是一个 MWE，看起来非常接近我的目标。我正在使用 Shiny、hexbin() 和 ggplotly。

app.R

library(shiny)
library(plotly)
library(data.table)
library(GGally)
library(reshape2)
library(hexbin)

ui <- fluidPage(
  plotlyOutput("plot"),
  verbatimTextOutput("click")
)

server <- function(input, output, session) {
  #Create data
  set.seed(1)
  bindata <- data.frame(x=rnorm(100), y=rnorm(100))

  h <- hexbin (bindata, xbins = 5, IDs = TRUE, xbnds = range (bindata$x), ybnds = range (bindata$y))

  # As we have the cell IDs, we can merge this data.frame with the proper coordinates
  hexdf <- data.frame (hcell2xy (h),  ID = h@cell, counts = h@count)

  # I have tried different methods of generating the ggplot object
  #p <- ggplot(hexdf, aes(x=x, y=y, fill = counts)) + geom_hex(stat="identity")
  #p <- ggplot(hexdf, aes(x=x, y=y, fill = ID)) + geom_hex(stat="identity")
  #p <- ggplot(hexdf, aes(x=x, y=y, fill = counts, colours = ID)) + geom_hex(stat="identity")
  #p <- ggplot(hexdf, colours = ID, aes(x=x, y=y, colours = ID, fill = counts)) + geom_hex(stat="identity")
  p <- ggplot(hexdf, aes(x=x, y=y, fill = counts, ID=ID)) + geom_hex(stat="identity")

  output$plot <- renderPlotly({
    ggplotly(p)
  })

  d <- reactive(event_data("plotly_click"))

  output$click <- renderPrint({
    if (is.null(d())){
      "Click on a state to view event data"
    }
    else{
      str(d())
      #Next line would deliver all observations from original data frame (bindata) that are in the clicked hexbin... if d() from event_data() was returning ID instead of curveNumber
      #bindata[which(h@cID==d()$curveNumber),]
    }
  })
}

shinyApp(ui, server)

h@cID 对象内部是所有数据点的 ID（显示哪个数据点进入哪个 hexbin）。因此，我觉得如果我能够在用户点击时让 event_data() 返回 hexbin ID，那么我应该能够成功地将 hexbin ID 映射回 h@cID 对象以获得相应的数据点。

不幸的是，按照我目前的编写方式，event_data() 将返回“curveNumber”，它似乎不等于 ID。它似乎也没有转换为 ID（即使使用 h 对象中的所有信息 - 不仅仅是 h@cID，还包括 h@xcm、h@ycm 等）

有没有人知道解决此类问题的方法？任何想法，将不胜感激！

注意：我最近的两篇文章（包括赏金）与这个问题非常相似。他们位于这里（ggplotly 中使用 geom_hex() 散点图进行交互式选择 https://stackoverflow.com/questions/41409890/interactive-selection-in-ggplotly-with-geom-hex-scatterplot) and (使用plotly和Shiny获取geom_hex中的观测值 https://stackoverflow.com/questions/41583889/obtain-observations-in-geom-hex-using-plotly-and-shiny）。不同的是，我每一步都让问题变得更加简单。谢谢。

编辑 - 可能的答案

我想我可能已经找到了这个问题的解决方案。就像 @oshun 注意到的那样，从 event_data() 返回的 curveNumber 和 hexbin ID 之间存在一些隐藏的转换。似乎 curveNumbers 首先通过增加十六进制数从最小到最大排序。然后，在给定的计数内，curverNumber 似乎通过增加 ID 进一步从小到大排序。但是，ID 是按特点 (not number）。例如，数字 18 将被视为小于数字 2，因为 18 以数字 1 开头，而数字 1 小于数字 2。

当本示例中的完整数据集用下面的 count、ID 和 curveNumber 表示时，您可以看到这种模式：

count=1 (ID=24) —> curveNumber 0
count=1 (ID=26) —> curveNumber 1
count=1 (ID=34) —> curveNumber 2
count=1 (ID=5) —> curveNumber 3
count=1 (ID=7) —> curveNumber 4
count=2 (ID=11) —> curveNumber 5
count=2 (ID=14) —> curveNumber 6
count=2 (ID=19) —> curveNumber 7
count=2 (ID=23) —> curveNumber 8
count=2 (ID=3) —> curveNumber 9
count=2 (ID=32) —> curveNumber 10
count=2 (ID=4) —> curveNumber 11
count=3 (ID=10) —> curveNumber 12
count=3 (ID=13) —> curveNumber 13
count=3 (ID=33) —> curveNumber 14
count=3 (ID=40) —> curveNumber 15
count=3 (ID=9) —> curveNumber 16
count=4 (ID=17) —> curveNumber 17
count=4 (ID=20) —> curveNumber 18
count=5 (ID=28) —> curveNumber 19 
count=5 (ID=8) —> curveNumber 20
count=6 (ID=21) —> curveNumber 21 
count=8 (ID=27) —> curveNumber 22 
count=9 (ID=22) —> curveNumber 23 
count=11 (ID=16)—> curveNumber 24
count=14 (ID=15)—> curveNumber 25

下面是我对这个问题的初步解决方案。我很确定它适用于此this数据集，但我计划在更多数据集上测试它以确定。

app.R

library(shiny)
library(plotly)
library(data.table)
library(GGally)
library(reshape2)
library(hexbin)

ui <- fluidPage(
  plotlyOutput("plot"),
  verbatimTextOutput("click")
)

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

  # Curve number to ID
  cnToID <- function(h){
    df <- data.frame(table(h@cID))
    colnames(df) <- c("ID","count")
    cnID <- df[order(df$count,as.character(df$ID)),]
    cnID$curveNumber <- seq(0, nrow(cnID)-1)
    return(cnID)
  }

  # Create data
  set.seed(1)
  bindata <- data.frame(x=rnorm(100), y=rnorm(100))
  h <- hexbin (bindata, xbins = 5, IDs = TRUE, xbnds = range (bindata$x), ybnds = range (bindata$y))
  hexdf <- data.frame (hcell2xy (h),  ID = h@cell, counts = h@count)
  p <- ggplot(hexdf, aes(x=x, y=y, fill = counts, ID=ID)) + geom_hex(stat="identity")
  #p <- ggplot(hexdf, aes(x=x, y=y, fill = counts), ID=ID) + geom_hex(stat="identity")
  cnID <- cnToID(h)

  output$plot <- renderPlotly({
    p2 <- ggplotly(p)
    for (i in 1:nrow(hexdf)){
      p2$x$data[[i]]$text <- gsub("<.*$", "", p2$x$data[[i]]$text)
    }
    p2
  })

  d <- reactive(event_data("plotly_click"))

  output$click <- renderPrint({
    if (is.null(d())){
      "Click on a state to view event data"
    }
    else{
      clickID <- as.numeric(as.character(cnID[which(cnID$curveNumber==d()$curveNumber),]$ID))
      clickID
      bindata[which(h@cID==clickID),]
    }
  })
}

shinyApp(ui, server)

Edit 2:

足够简化您的问题，以便我可以给您部分答案。下面的代码允许您单击分箱数据（绘制为正方形）并获取原始数据。

情节返回信息点击事件 https://plot.ly/r/shiny-coupled-events/形式为x, y, curveNumber and pointNumber. curveNumber索引跟踪，但这似乎取决于绘图的调用方式。pointNumber似乎根据数据的顺序进行索引（并且它也链接到curveNumber）。如果仅绘制一组点，则映射到原始数据相对简单。

下面的解决方案适用于点，因为它使用pointNumber (x and y可能是更好的查找组合，因为这些是绝对值而不是相对顺序）。该解决方案不适用于geom_hex正如您最初要求的六边形，因为只有curveNumber单击鼠标即可返回。看起来六边形首先通过计数添加，然后通过其他一些排序变量添加。解决背后的原理curveNumber如果你想使用的话，编号是关键geom_hex.

下面是两个屏幕截图： 左 = 原始图geom_hex。右 = 修改后的图geom_point using pointNumber正确索引结果。

修改后的代码如下。 OP和我都大量借鉴了这个answer https://stackoverflow.com/a/14586941/4718512关于六边形。

library(shiny); library(plotly); library(GGally); library(reshape2); library(hexbin)

ui <- fluidPage(
  plotlyOutput("plot"),
  checkboxInput("squarePoints", label = "Switch to points?"),
  verbatimTextOutput("click"),
  HTML("Check the work:"),
  plotlyOutput("plot1")
)

server <- function(input, output, session) {
  #Create data
  set.seed(1)
  bindata <- data.frame(myIndex = factor(paste0("ID",1:100)), 
                        x=rnorm(100), y=rnorm(100))

  h <- hexbin (bindata[,2:3], xbins = 5, IDs = TRUE, 
               xbnds = range(bindata$x), ybnds = range(bindata$y))

  # As we have the cell IDs, we can merge this data.frame with the proper coordinates
  hexdf <- data.frame (hcell2xy (h),  ID = h@cell, counts = h@count)

  #New code added below ###
  counts <- hexTapply(h, bindata$myIndex, table)  #list of 26
  counts <- t(simplify2array (counts))
  counts <- melt (counts)                 #2600 rows = 26 hexagons * 100 observations
  colnames (counts)  <- c ("ID", "myIndex", "present")

  allhex <- merge (counts, hexdf)         #2600 rows = 26 hexagons * 100 observations
  #rename hex coordinates
  names(allhex)[names(allhex) %in% c("x", "y")] <- c("hex.x", "hex.y")  
  allhex <- merge(allhex, bindata)
  somehex <- allhex[allhex$present > 0,]  #100 rows (original data)

  #Plotly graphs objects in a certain order, so sort the lookup data by the same order 
  #in which it's plotted.
  #No idea how curveNumber plots data. First by counts, then by ...?
  #pointNumber seems more straightforward. 
  sorthex <- hexdf[with(hexdf, order(ID)), ]

  #Create a switch to change between geom_hex() and geom_point()
  switchPoints <- reactive(if(input$squarePoints) {
    geom_point(shape = 22, size = 10)
    } else {  
      geom_hex(stat = "identity")
      })

  hexdf$myIndex <- "na" #Added here for second plotly
  ### New code added above ###

  p <- reactive(ggplot(hexdf, aes(x=x, y=y, fill = counts))  + coord_equal() +
                switchPoints() )

  output$plot <- renderPlotly({
    ggplotly(p())
  })

  d <- reactive(event_data("plotly_click"))
  #pointNumber = index starting from 0
  hexID <- reactive(sorthex[d()$pointNumber + 1, "ID"]) 

  output$click <- renderPrint({
    if (is.null(d())){
      "Click on a state to view event data"
    }
    else{
      list(
      str(d()),
      somehex[somehex$ID == hexID(),]
      )
    }
  })

  #Check your work: plot raw data over hexagons
  p.check <- ggplot(hexdf, aes(x=x, y=y, fill = counts)) + geom_hex(stat="identity") +
    geom_point(data = somehex, aes(x=x, y=y)) + coord_equal()

  output$plot1 <- renderPlotly({
    ggplotly(p.check + aes(label= myIndex) )
  })


}

shinyApp(ui, server)