RGL 可以在 RStudio 中的信息上做 plotly-style hover - identify3d 和 selectpoints3d

Question

有人可以澄清 identify3d 的作用以及如何使用它吗？ 我试试

Reprex 数据和库：

library(rgl)
library(plotly)
library(dplyr)
rgl::setupKnitr(autoprint = TRUE) #To see plots in RStudio


plot_issue_dat <- structure(list(vb = structure(c(-3.02, -115.799, 203.187, 1, 
-0.715, -115.701, 202.444, 1, -3.024, -114.397, 201.275, 1, -2.058, 
-116.181, 203.556, 1, 4.437, -116.153, 205.384, 1, 4.471, -114.791, 
210.117, 1, 12.443, -105.538, 198.121, 1, 4.985, -107.238, 192.985, 
1, 5.458, -107.907, 193.987, 1, 5.061, -115.557, 207.515, 1, 
6.809, -114.172, 208.797, 1, 5.8, -115.493, 205.988, 1, 4.943, 
-111.077, 198.177, 1), dim = c(4L, 13L)), material = list(), 
    normals = NULL, texcoords = NULL, meshColor = "vertices", 
    it = structure(c(1L, 2L, 3L, 4L, 5L, 2L, 2L, 1L, 4L, 6L, 
    1L, 3L, 7L, 8L, 9L, 3L, 8L, 7L, 6L, 4L, 1L, 10L, 11L, 12L, 
    7L, 6L, 3L, 11L, 6L, 7L, 2L, 5L, 13L, 7L, 9L, 13L, 11L, 7L, 
    12L, 6L, 11L, 10L, 3L, 2L, 13L, 5L, 10L, 12L, 9L, 8L, 13L, 
    13L, 8L, 3L, 4L, 6L, 10L, 5L, 4L, 10L, 7L, 13L, 12L, 12L, 
    13L, 5L), dim = c(3L, 22L))), class = c("mesh3d", "shape3d"
))

points3d(x=plot_issue_dat$vb[1,], 
       y=plot_issue_dat$vb[2,], 
       z=plot_issue_dat$vb[3,])
axes3d()  

产生这个 plot：

我可以使用 identify3d 获取 plotly 样式的悬停信息以查看如下内容吗：

我发现 2017 年的类似讨论表明： R：交互式 3D plotly 散点图 rgl-style with hover 信息

我还希望能够在空间中存储 select 点并存储该数据以供日后使用，我认为 identify3d() 可以实现这一点，但我不确定如何将它与 RStudio 一起使用，当我将它包含在我的代码中时，它似乎可以运行但是我什么也没看到

Answer 1

关于“奖励积分”： select3d()的帮助页面上有一个示例。 它不执行 hover 信息。 您通过在区域上拖动一个矩形来运行 function、select 一个区域，然后 function 返回一个 function，它可以告诉您特定点是否在所选区域中。

不存在执行 hover 信息的现有 function，但您可以通过修改identify3d()的源代码来编写一个。 例如：

hover3d <- function(x, y = NULL, z = NULL, 
                    labeller = labelIndex,
                    labels = seq_along(x),
                    adj = c(-0.1, 0.5),
                    tolerance = 20, 
                    cumulative = FALSE) {
  
  labelIndex <- function(sel)
    text3d(x[sel], y[sel], z[sel], texts=labels[sel], adj=adj)

  stopifnot(is.function(labeller))
  
  opar <- par3d("mouseMode")
  odisp <- cur3d()
  
  xyz <- xyz.coords(x, y, z)
  x <- xyz$x
  y <- xyz$y
  z <- xyz$z
  if (length(x)==0) 
    stop("No points to identify.")
  
  force(labels)
  force(adj)
  
  selected <- list()
  
  select <- function(mousex, mousey) {
    disp <- cur3d()
    if (disp != odisp) {
      set3d(odisp)
      on.exit(set3d(disp))
    }
    viewport <- par3d("viewport")
    winxyz <- rgl.user2window(xyz)
    winxyz[,1] <- winxyz[,1]*viewport[3]
    winxyz[,2] <- (1-winxyz[,2])*viewport[4]
    
    dist <- sqrt( (mousex-winxyz[,1])^2 + (mousey - winxyz[,2])^2 )
    dist[winxyz[,3] < 0 | winxyz[,3] > 1] <- Inf
    sel <- which.min(dist)
    if (dist[sel] < tolerance) {
      save <- par3d(skipRedraw = TRUE)
      on.exit(par3d(save), add = TRUE)
      if (!cumulative)
        selected <<- Filter(function(s) 
                             if (s$sel != sel) {
                               pop3d(id = s$ids)
                               FALSE
                             } else TRUE, selected)
      prev <- Find(function(s) 
                     s$sel == sel, selected)
      if (is.null(prev)) {
        this <- list(sel = sel, ids = labeller(sel))
        selected <<- c(selected, list(this))
      }
    }
  }
  
  rgl.setMouseCallbacks(0, update=select)
  invisible(list(oldPar = opar, oldDisplay = odisp))
}

labelLocation <- function(x, y = NULL, z = NULL) {
  xyz <- xyz.coords(x, y, z)
  function(sel)
    with(xyz,
         c(text3d(x[sel], y[sel], z[sel], sprintf("x:%.2f", x[sel]), 
                  adj = c(-0.2, -0.6)),
           text3d(x[sel], y[sel], z[sel], sprintf("y:%.2f", y[sel]),
                  adj = c(-0.2, 0.5)),
           text3d(x[sel], y[sel], z[sel], sprintf("z:%.2f", z[sel]),
                  adj = c(-0.2, 1.6)))
    )
}

xyz <- matrix(rnorm(30), ncol = 3)
plot3d(xyz)

hover3d(xyz, labeller = labelLocation(xyz))

Answer 2

有一种方法可以通过使用来自 nat 的 wire3d 来获取每个顶点的信息而无需修改源： https://natverse.org/nat/reference/wire3d.html

这仅适用于比 CRAN 上可用的版本更新的版本。

options(nat.plotengine = 'plotly')
wire3d(plot_issue_dat,
       add = FALSE
)  |> 
  add_trace(
    name = "Faces",
    type = "mesh3d",
    x = plot_issue_dat$vb[1,], y = plot_issue_dat$vb[2,], z = plot_issue_dat$vb[3,],
    i = plot_issue_dat$it[1,]-1, j = plot_issue_dat$it[2,]-1, k = plot_issue_dat$it[3,]-1,
    opacity = 0.5,
    flatshading = TRUE, # we don't want smoothing
    showlegend=TRUE,
    facecolor = rep("red", ncol(plot_issue_dat$it))
  ) |>
  add_trace(
    type = "scatter3d",
    mode = "markers",
    name = "LAT",
    x = plot_issue_dat$vb[1,],
    y = plot_issue_dat$vb[2,],
    z = plot_issue_dat$vb[3,],
    showlegend = TRUE,
    alpha = 0.2,
    marker = list(
      colorbar = list(x = -.5))
  ) |>
  layout(showlegend = TRUE)

使用 nat v1.10.4 生成