r - (已关闭)R Shiny应用程序中的覆盖小部件

Question

tl; dr 我想将plotOutput覆盖在imageOutput之上。我没有CSS / HTML知识。

我面临的全部问题:
另一个 tl; dr 我想用闪亮的颜色复制this，并且必须快!

想象一下一个小的3 x 4 x 5 3D数组，它由单位正方形组成(所以总共60个正方形)。我希望用户分别可视化这三个平面。对于每个平面XY，YZ和XZ，我都有三个imageOutput(或plotOutput)。我在这里将它们称为plane。像this这样的东西(我只是在Google上搜索了此图片，而不是我的图片)。加载应用程序时，我渲染每个plane的中心，并用十字准线指向(crossing？)。现在，当用户单击任何plane(例如XY)时，我得到了光泽单击的协调，并使用新图像(在本例中为YZ和XZ)协调了新的plane和x，使用其他图像更新了其他y。同时更新所有三个的十字准线。最终结果就是这个图像here。除了所有三个都在单独的视图中。
所以我已经有执行此操作的代码，但是加载时间很麻烦。因为实际输入的尺寸为~ 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。也尝试过this，但同样没有希望。

决定首先将所有平面(所有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图层，该图层会将图像渲染为背景，并在绘图中添加十字线。类似于this。但是，再次加载png并重做所有操作会减慢它的速度，说实话似乎没有用。我使用magick更快地加载png。但是同样，太慢了。 imager。

我搞不清楚了。我从未进行过优化，所以我不知道 Rcpp。我愿意尝试一下，但是我想知道这是正确的方向，还是尝试其他方法。我愿意接受所有建议。如果您需要更多详细信息或代码，请发表评论。谢谢!

编辑:标题大声笑，我想知道是否有可能以某种方式将 plotOutput覆盖在 imageOutput上，并获得 ggplot以仅添加十字线。我猜测这将节省大量时间，并且应该足以加快速度。

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

更新:我可能应该提到输入数组是灰度图像，但没有上限或下限的限制(它不受0-1范围的限制)

更新:因此，我在笔记本电脑上编写了一个微型应用程序，原始代码实际上非常快。我认为我们在工作中使用的RStudio服务器相当慢。但是，我正在发布代码。

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)

最终更新:事实证明，我们使用的服务器通常会在仿真和工作方面做很多繁重的工作，从而大大降低了代码的速度。尽管问题尚未解决，但我想我们正在寻找错误的问题。无论如何，我将把赏金授予西蒙。谢谢你的回答。

Answer 1

这种方法使用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重复此过程。