r - （已关闭）R 闪亮应用程序中的覆盖小部件

问题描述

tl;博士我想将 a 覆盖plotOutput在imageOutput. 我没有 CSS/HTML 知识。

我面临的全部问题：
另一个tl;dr我想以闪亮的方式复制它，并且必须快！

想象一个由单位正方形组成的小型3 x 4 x 53D 阵列（总共 60 个正方形）。我希望用户分别可视化这三个平面。每个平面 XY、YZ 和 XZ我都有三个imageOutput（或）。plotOutput我将在此提及这些plane。像这样的东西（我只是在谷歌上搜索了这个，而不是我的图片）。加载应用程序时，我渲染每个的中心plane，十字准线指向（交叉？）在同一中心。现在，当用户单击任何planeXY 时，我会在闪亮中获得单击的协调，并plane使用新图像更新另一个，在本例中为 YZ 和 XZ，使用新的x和y协调。还更新了所有三个的十字准线。最终结果正是这里的图像。除了所有三个都在不同的视图中。
所以我已经有代码可以做到这一点，但是加载时间很痛苦。因为实际输入是维度的~ 250 x 250 x 100。所有三架飞机加载大约需要 2-3 秒。该应用程序应该提供一个界面来快速轻松地查看飞机，并且延迟最少。所以基本上，我要加快速度。

关于使用的变量：

x()是reactive输入。
meta()是一个reactive存储维度的x().
values$xyz是一个长度为 3 的数组，用于十字准线的 x、y 和 z。

我试图在这篇文章中获得尽可能多的细节，因为这是一个复杂的问题。请原谅帖子的长度。

到目前为止，我已经尝试了几件事：

第一个想法是在飞行中渲染飞机。我有plotOutput和ui下面的代码server。

output$plotXY <- renderPlot({
    req(x())
    par(oma = rep(0, 4), mar = rep(0, 4), bg = "black")
    graphics::image(1:meta()$X, 1:meta()$Y,
                x()[, , values$xyz[3]],
                col = gray(0:64/64),
                xlab = "", ylab = "",
                axes = FALSE,
                useRaster = T)
    abline(h = values$xyz[2], v = values$xyz[1], col = "red")
})

就像我上面提到的，非常慢。

以为ggplot2会更快，所以基本上将上面的代码移植到ggplot.

ggplot(melt(x()[, , values$xyz[3]]), aes(Var1, Var2, fill = value)) +
  geom_raster(show.legend = F) +
  theme_void() +
  scale_fill_gradient(low = "black", high = "white") +
  geom_vline(xintercept =  values$xyz[1], color = "red") +
  geom_hline(yintercept =  values$xyz[2], color = "red")

这确实加快了进程，但可以忽略不计。我用过microbenchmark。也试过这个，但同样没有希望。

决定首先将所有平面（所有 XY、YZ 和 XZ）保存为临时文件中的 png，并在需要时加载。现在使用imageOutput在ui.
```
# preprocessing:
makePNG <- function(slice) {

  outfile = tempfile(fileext = ".png")
  dims = dim(slice)
  png(outfile, width = dims[1], height = dims[2])
  par(mar = c(0,0,0,0))
  image(slice, useRaster=T, axes=F, col = gray(0:64/64))
  dev.off()

  return(outfile)
}
...
  file_paths_XY <- apply(x(), 3, makePNG) # also in meta()
...
# loading images:
output$plotXY <- renderImage({
  req(x())
  pos = values$xyz[3]
  file_path = meta()$file_paths_XY[pos]
  list(
    src = file_path
  )
}, deleteFile = F)
```
这明显更快，但自然地，初始加载时间很长！为了加快预处理，我尝试了这个parallel包，但是传输整个的开销x()太贵了。我正在考虑实现一个惰性加载器，所以每架飞机只能加载 10 个，然后如果需要再加载 10 个。还没有落实。但真正的问题是，我需要十字准线（还有一些重新缩放和旋转）！我决定ggplot再次使用并添加一个annotation_custom将图像渲染为背景的图层，并在绘图中添加十字准线。与此类似。但是再次加载 png 并重做所有内容会减慢它的速度，而且老实说似乎没用。我曾经magick更快地加载png。但同样，太慢了。imager 也。

我搞不清楚了。我从来没有做过优化，所以我不知道Rcpp。我愿意尝试它，但我想知道这是否是正确的方向，或者尝试其他方法。我对所有和任何建议持开放态度。如果您需要更多详细信息或代码，请发表评论。谢谢！

编辑：标题大声笑，我想知道是否有可能以某种方式覆盖 aplotOutput并添加十字准线。我猜这会节省很多时间，应该足以加快速度。imageOutputggplot

更新：我很想让这个可重现，但我认为我没有足够的 R 和 Shiny 经验。这是一个闪亮的应用程序模块。更大的应用程序会调用callModule要显示的图像的路径。我将如何使它可重现？

更新：我可能应该提到输入数组是灰度图像，但对高点或低点没有限制（它不绑定到 0-1 范围）

更新：所以我在笔记本电脑上编写了一个迷你应用程序，原始代码实际上非常快。我认为我们在工作中使用的 RStudio Server 相当慢。尽管如此，我正在发布代码。

library(shiny)

ui <- fluidPage(
  fluidRow(
    column(4, plotOutput("plotXY", click = "plotXY_click")),
    column(4, plotOutput("plotXZ", click = "plotXZ_click")),
    column(4, plotOutput("plotYZ", click = "plotYZ_click"))
  )
)

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

  data <- array(sample(x=100, size=250*250*100, replace = T), dim=c(250,250,100))
  X <- 250
  Y <- 250
  Z <- 100
  dim <- c(250, 250, 100)

  values <- reactiveValues()
  values$xyz <- ceiling(dim/2)

  output$plotXY <- renderPlot({
    par(oma = rep(0, 4), mar = rep(0, 4), bg = "black")

    img_data = data[,,values$xyz[3]]

    graphics::image(1:X, 1:Y,
                    img_data,
                    col = gray(0:64/64),
                    xlab = "", ylab = "",
                    axes = FALSE,
                    useRaster = T)
    abline(h = values$xyz[2], v = values$xyz[1], col = "red")
  })

  observeEvent(input$plotXY_click, {
    values$xyz[1] <- input$plotXY_click$x
    values$xyz[2] <- input$plotXY_click$y
  })

   output$plotXZ <- renderPlot({
    par(oma = rep(0, 4), mar = rep(0, 4), bg = "black")

    img_data = data[,values$xyz[2],]

    graphics::image(1:X, 1:Z,
                    img_data,
                    col = gray(0:64/64),
                    xlab = "", ylab = "",
                    axes = FALSE,
                    useRaster = T)
    abline(h = values$xyz[3], v = values$xyz[1], col = "red")
  })

  observeEvent(input$plotXZ_click, {
    values$xyz[1] <- input$plotXZ_click$x
    values$xyz[3] <- input$plotXZ_click$y
  })

  output$plotYZ <- renderPlot({
    par(oma = rep(0, 4), mar = rep(0, 4), bg = "black")

    img_data = data[values$xyz[1],,]

    graphics::image(1:Y, 1:Z,
                    img_data,
                    col = gray(0:64/64),
                    xlab = "", ylab = "",
                    axes = FALSE,
                    useRaster = T)
    abline(h = values$xyz[3], v = values$xyz[2], col = "red")
  })

  observeEvent(input$plotYZ_click, {
    values$xyz[2] <- input$plotYZ_click$x
    values$xyz[3] <- input$plotYZ_click$y
  })
}

shinyApp(ui, server)

最后更新：所以事实证明，我们使用的服务器通常在模拟和其他东西方面做了很多繁重的工作，从而大大降低了代码速度。虽然问题还没有解决，但我想我们看错了问题。无论如何，我要把赏金奖励给西蒙。谢谢你的回答。

标签： rggplot2shiny

解决方案

这种方法使用 3D 阵列，其每个平面都是灰度图像。通过分别跟踪每种颜色，可以将其推广到 rgb。灵感来自在 Matlab 中处理矩阵。

首先设置一些虚拟数据：

# GREY
G = runif(250*250*100)
G = array(G, c(250,250,100))

其中 G 是图像的灰度分量。

假设坐标X = 40被选中。然后我们提取 YZ plane：

ptm = proc.time()
X = 40
YZ_panel = G[40,,]

这可以在 ggplot 中显示为图像：

g <- rasterGrob(YZ_panel, interpolate=TRUE)

qplot(c(1,10,10,1,1),c(1,1,25,25,1),geom="blank") +
  annotation_custom(g, xmin=0, xmax=10, ymin=0, ymax=25) +
  geom_line(aes(x=c(5,5), y=c(0,25)), color="red") +
  geom_line(aes(x=c(0,10), y=c(10,10)), color="red") + 
  coord_fixed()

使用proc.time()我得到了不到半秒的结果：

proc.time() - ptm
   user  system elapsed 
   0.18    0.03    0.21

您当然必须对每个plane.

r - （已关闭）R 闪亮应用程序中的覆盖小部件

问题描述

解决方案

推荐阅读