ros*_*ova 5 r image ggplot2 shiny
我正在制作一个应用程序shiny，允许用户单击以选择图像上的点。我用来ggplot2将选择的点显示为图像上的红点。
我的工作方式非常接近我想要的方式，除了每次用户单击新点时，整个图像都会重新加载*。理想情况下，我会在每次单击时重新绘制数据，但不会重新加载整个图像。
我的问题是，是否可以让绘图点反应性地重新加载，但保留背景图像（因为它在点击之间不会改变）？
我的实际应用程序比这更复杂，但这是我对我想要解决的问题的最小可重现示例的最佳尝试（请注意，您需要调整image.file以指向计算机上的 jpg 文件才能运行这个；我不知道如何使图像本身可重现，抱歉）：
library( ggplot2 )
library( jpeg )
library( grid )
library( shiny )
#### pre-run setup ####
# set up a function for loading an image file as a grob
grob_image <- function( file ) {
grid::rasterGrob( jpeg::readJPEG( file ), interpolate = TRUE )
}
# initiate a ggplot theme for use in plotting
# (just getting rid of everything so we only see the image itself)
theme_empty <- theme_bw()
theme_empty$line <- element_blank()
theme_empty$rect <- element_blank()
theme_empty$strip.text <- element_blank()
theme_empty$axis.text <- element_blank()
theme_empty$plot.title <- element_blank()
theme_empty$axis.title <- element_blank()
# set the image input file
image.file <- "session2_ebbTriggerCountMap.jpg"
#### UI ####
ui <- fluidPage(
# display the image, with any click-points
fluidRow(
plotOutput("plot",
click = "image_click"
)
)
)
### SERVER ####
server <- function(input, output, session) {
# initialise a data.frame for collecting click points
data.thisimage <- data.frame( x = rep( NA_real_, 100L ), y = rep( NA_real_, 100L ) )
# initalise the plot (this is the image on which to put any points we get)
# the `geom_blank` here is to set up the x and y axes as per the width and height of the image
img <- grob_image( image.file )
base <- ggplot() +
geom_blank( data = data.frame( x = c( 0, dim( img$raster )[2] ), y = c( 0, dim( img$raster )[1] ) ),
mapping = aes( x = x, y = y )
) +
theme_empty +
annotation_custom( grob = img )
# plot the image
output$plot <- renderPlot( {
base
} )
#### click action ####
# watch for a mouse click (point selected on the plot)
observeEvent( input$image_click, {
# add a row of data to the data frame
data.thisimage[ which( is.na( data.thisimage$x ) )[1L], ] <<- c(
input$image_click$x, input$image_click$y
)
# re-render the plot with the new data
output$plot <<- renderPlot( {
base +
geom_point( data = data.thisimage[ !is.na( data.thisimage$x ), ],
mapping = aes( x = as.numeric( x ), y = as.numeric( y ) ),
colour = "red" )
} )
} )
}
shinyApp(ui, server)
由于每次单击鼠标都会重新加载图像，因此我预计 UI 反应性、CPU 负载和数据传输负载会出现问题。有什么办法可以缓解吗？
* 从代码本身来看，这可能是显而易见的，但我已经通过观察 CPU 负载，同时一遍又一遍地单击加载的大图像来向自己证明了这一点。
注意我能找到的最接近我的问题的是这个SO问题。不幸的是，它不能解决重新加载图像的问题，只能加快数据点的渲染速度，这不是我的问题。在 Shiny 中更新大图而无需重新渲染
我将首先尝试建议一个较短版本的代码，以确保哪一部分是最重要的部分。
我将 base <- ggplot() 从服务器中取出，因为它依赖于静态值，并且可以执行一次。
我创建了 xy_coord() 捕获点击 xy 坐标。
我使用shinySignals::reducePast 将值添加到数据框xy_click()。注意：shinySignals 仍在开发中，因此如果您愿意，您可以自己编写该函数。
现在，我假设你的问题是在baserenderPlot 中，对吗？
output$plot <- renderPlot({
base +
geom_point(...)
})
在更新的解决方案中：
在 UI 中，我在 div“容器”内创建了两个彼此重叠的 div，底部用于 jpeg 图像，第二个用于点。
我在底部绘制了一次 jpeg 图像output$plot
click="image$click"我使用了第二个图的单击选项output$plot1，每次都会渲染它，因为它位于顶部。
我使用bg="transparent"选项让图像在背景中可见。
额外的
output$plot <- renderPlot(...)您甚至可以通过将图像移动到应用程序文件夹中的文件夹并在第一个使用www中嵌入图像来避免使用divtags$img
| shinyApp/
| app.R
| www/
| survey.jpg
注意：这应该在图像和plot2完美对齐的情况下起作用，我还没有进行深入测试，但我尝试了几个例子。
更新的解决方案
library(ggplot2)
library(jpeg)
library(grid)
library(shiny)
#### pre-run setup ####
# initiate a ggplot theme for use in plotting
# (just getting rid of everything so we only see the image itself)
theme_empty <- theme_bw()
theme_empty$line <- element_blank()
theme_empty$rect <- element_blank()
theme_empty$strip.text <- element_blank()
theme_empty$axis.text <- element_blank()
theme_empty$plot.title <- element_blank()
theme_empty$axis.title <- element_blank()
# set the image input file
image.file <- "www/survey.jpg"
img <- jpeg::readJPEG(image.file)
## set up a function for loading an image file as a grob ---------------------
# grob_image <- function(file) {
# grid::rasterGrob( jpeg::readJPEG(file), interpolate = TRUE )
# }
## load the image as a a grob ---------------------
# img <- grob_image(image.file)
#### UI ####
ui <- fluidPage(
# Overlapping images in 2 divs inside a "container"
fluidRow(
div(id="container",
height = dim(img)[1],
width = dim(img)[2],
style="position:relative;",
div(tags$img(src='survey.jpg',
style=paste0("width:",dim(img)[2],";height:",dim(img)[2],";")),
# plotOutput("plot",
# height = dim(img)[1],
# width = dim(img)[2],
# click = "image_cl1"),
style="position:absolute; top:0; left:0;"),
div(plotOutput("plot1",
height = dim(img)[1],
width = dim(img)[2],
click = "image_click"),
style="position:absolute; top:0; left:0;")
)
)
)
### SERVER ####
server <- function(input, output, session) {
## get clicked point coordinates -----------------------
xy_coord <- reactive(c(input$image_click$x,input$image_click$y))
## add the new points to the dataframe -----------------
xy_clicks <- shinySignals::reducePast(xy_coord,
function(x,y){
df <- x
nn <- nrow(df)
# add values in case of click
if(length(y)>0){
df[nn+1,1 ] <- y[1]
df[nn+1,2 ] <- y[2]
}
return(df)
},
init=data.frame(x_coord=numeric(0),
y_coord=numeric(0)))
## render plot of the jpeg image --------------------------------------
# output$plot <- renderPlot({
# ggplot()+
# geom_blank(data = data.frame(x = c(0, dim(img$raster)[2])
# , y = c(0, dim(img$raster)[1])),
# mapping = aes(x = x, y = y))+
# theme_empty +
# annotation_custom(grob = img)
# })
# alternative for plot of the jpeg image
# output$plot <- renderPlot({
# # plot_jpeg("survey.jpg")
# })
## re-render the plot with the new data -------------------------
output$plot1 <- renderPlot({
ggplot() +
geom_blank(data = data.frame(x = c(0,dim(img)[2])
,y = c(0,dim(img)[1])),
mapping = aes(x = x,
y = y))+
theme_empty+
geom_point(data = xy_clicks(),
mapping = aes(x = x_coord,
y = y_coord),
colour = "red")+
coord_cartesian(xlim = c(0,dim(img)[2]),
ylim= c(0,dim(img)[1]))
},
bg="transparent")
}
## uncomment and add verbatimTextOutput("txt") in UI to see the xy_clicks() dataframe
# output$txt <- renderPrint(xy_clicks())
# Run the application
shinyApp(ui = ui, server = server)
我的原始代码版本
library(ggplot2)
library(jpeg)
library(grid)
library(shiny)
#### pre-run setup ####
# set up a function for loading an image file as a grob
grob_image <- function( file ) {
grid::rasterGrob( jpeg::readJPEG( file ), interpolate = TRUE )
}
# initiate a ggplot theme for use in plotting
# (just getting rid of everything so we only see the image itself)
theme_empty <- theme_bw()
theme_empty$line <- element_blank()
theme_empty$rect <- element_blank()
theme_empty$strip.text <- element_blank()
theme_empty$axis.text <- element_blank()
theme_empty$plot.title <- element_blank()
theme_empty$axis.title <- element_blank()
# set the image input file
image.file <- "survey.jpg"
## initalise the plot (this is the image on which to put any points we get)
# the `geom_blank` here is to set up the x and y axes as per the width and height of the image
img <- grob_image(image.file)
## create base plot -----------------------
base <- ggplot() +
geom_blank(data = data.frame(x = c(0, dim( img$raster )[2])
, y = c(0, dim( img$raster )[1])),
mapping = aes(x = x, y = y)
) +
theme_empty +annotation_custom(grob = img)
#### UI ####
ui <- fluidPage(
# display the image, with any click-points
fluidRow(
plotOutput("plot",
height = dim( img$raster )[1],
width = dim( img$raster )[2],
click = "image_click"
)
)
)
### SERVER ####
server <- function(input, output, session) {
## get clicked point coordinates -----------------------
xy_coord <- reactive(c(input$image_click$x,input$image_click$y))
## add the new points to the dataframe -----------------
xy_clicks <- shinySignals::reducePast(xy_coord,
function(x,y){
df <- x
nn <- nrow(df)
# add values in case of click
if(length(y)>0){
df[nn+1,1 ] <- y[1]
df[nn+1,2 ] <- y[2]
}
return(df)
},
init=data.frame(x_coord=numeric(0),
y_coord=numeric(0)))
## re-render the plot with the new data -------------------------
output$plot <- renderPlot({
base +
geom_point(data = xy_clicks(),
mapping = aes(x = x_coord, y = y_coord),
colour = "red")
})
## uncomment and add verbatimTextOutput("txt") in UI to see the xy_clicks() dataframe
# output$txt <- renderPrint(xy_clicks())
}
# Run the application
shinyApp(ui = ui, server = server)