我正在制作一个闪亮的应用程序,允许用户点击选择图像上的点.我正在使用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负载来证明这一点,同时在加载大图像时反复点击.
注意我能找到的最接近我的问题的是这个问题.不幸的是,它没有解决重新加载图像的问题,只加快了数据点的渲染速度,这不是我的问题. Update large plots in Shiny without Re-Rendering
最佳答案 我将首先尝试建议一个较短版本的代码,以确保哪个部分是重的.
>我将base< – ggplot()从服务器中取出,因为它依赖于静态值,并且可以执行一次.
>我创建了xy_coord()捕获单击x-y坐标.
>我使用shinySignals :: reducePast将值添加到数据帧xy_click().注意：shinySignals仍处于开发阶段,因此如果您愿意,可以自己编写该函数.
>现在,我认为你的问题是在renderPlot中有基础,对吗？
输出$plot< – renderPlot({
基础
geom_point(…)
})
在更新的解决方案中：
>在UI中,我在div“container”中创建了两个div,jpeg图像的底部和点的第二个div.
>我在底部输出$plot绘制了一次jpeg图像
>我使用了click optionclick =“image $click”第二个绘图输出$plot1,每次都会渲染,因为它位于顶部.
>我使用bg =“transparent”选项让图像在背景中可见.
额外
您甚至可以通过将图像移动到app文件夹中的www文件夹并使用标签$img将图像嵌入到第一个div中来避免使用输出$plot< – renderPlot(…)
| 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)
