r-如何在带有ggplotly()的闪亮应用程序中使用plotlyProxy()，使绘图渲染更快

Question

我一直在寻找一个解决这个问题的问题，但我没有看到。。我正在创建一个闪亮的应用程序，它使用ggplotly()使我的图形具有交互性。该图是基于用户selectInput()下拉菜单的反应图。一切都很好，但当我在下拉菜单中单击新参数时，渲染绘图需要很长时间。通过研究，我发现了这篇文章，改进ggplotly转换，这解释了为什么绘制需要很长时间(我有很多数据(。网站上说要使用plotlyProxy()。然而，我在尝试将其实现到我的代码中时遇到了困难。更具体地说，我不知道如何使用你必须使用的plotlyProxyInvoke()功能。如果有任何指导，我将不胜感激！

样本数据：

df<-structure(list(stdate = structure(c(17694, 14581, 14162, 14222, 
17368, 16134, 17414, 13572, 17613, 15903, 14019, 12457, 15424, 
13802, 12655, 14019, 16143, 17191, 13903, 12362, 12929, 13557, 
16758, 13025, 15493, 16674, 15959, 15190, 16386, 11515, 12640, 
15295, 15664, 15145, 17077, 14914, 14395, 14992, 13271, 12730
), class = "Date"), sttime = structure(c(35460, 42360, 32880, 
30600, 26760, 45000, 36000, 32700, 39000, 35460, 34200, 28800, 
26400, 33900, 39600, 29280, 34500, 28920, 31320, 34800, 37800, 
42000, 34560, 27000, 35280, 37800, 36000, 32940, 30240, 42900, 
28800, 35100, 35400, 39600, 30420, 41100, 34500, 32040, 37800, 
36000), class = c("hms", "difftime"), units = "secs"), locid = c("BTMUA-SB1", 
"BTMUA-INTAKE", "BTMUA-SA", "USGS-01394500", "BTMUA-NA", "USGS-01367785", 
"NJDEP_BFBM-01411461", "BTMUA-SD", "NJDEP_BFBM-01443293", "BTMUA-SL", 
"USGS-01396660", "USGS-01390400", "BTMUA-SA", "21NJDEP1-01407670", 
"USGS-01477440", "BTMUA-NA", "BTMUA-SA", "BTMUA-SE", "BTMUA-SA", 
"USGS-01405340", "USGS-01444990", "BTMUA-SG", "BTMUA-SB1", "USGS-01467359", 
"BTMUA-SA", "USGS-01382000", "USGS-01412800", "BTMUA-NA", "BTMUA-SI", 
"31DRBCSP-DRBCNJ0036", "21NJDEP1-01410230", "USGS-01465861", 
"BTMUA-NF", "USGS-01445210", "BTMUA-NA", "USGS-01464020", "BTMUA-SL", 
"BTMUA-SA", "USGS-01382500", "USGS-01408598"), charnam = c("Total dissolved solids", 
"Total dissolved solids", "Total dissolved solids", "Total dissolved solids", 
"Total dissolved solids", "Total dissolved solids", "Total dissolved solids", 
"Total dissolved solids", "Total dissolved solids", "Total dissolved solids", 
"Total dissolved solids", "Total dissolved solids", "Total dissolved solids", 
"Total dissolved solids", "Total dissolved solids", "Total dissolved solids", 
"Total dissolved solids", "Total dissolved solids", "Total dissolved solids", 
"Total dissolved solids", "Total dissolved solids", "Total dissolved solids", 
"Total dissolved solids", "Total dissolved solids", "Total dissolved solids", 
"Total dissolved solids", "Total dissolved solids", "Total dissolved solids", 
"Total dissolved solids", "Total dissolved solids", "Total dissolved solids", 
"Total dissolved solids", "Total dissolved solids", "Total dissolved solids", 
"Total dissolved solids", "Total dissolved solids", "Total dissolved solids", 
"Total dissolved solids", "Total dissolved solids", "Total dissolved solids"
), val = c(126, 84, 97, 392, 185, 157, 62, 149.4, 274, 60, 134, 
516, 121, 144, 143, 99, 154, 120, 96, 99, 278, 96.2, 135, 101, 
110, 460, 147, 117, 102, 250, 75, 121, 129, 242, 172, 279, 51, 
205, 88, 38), valunit = c("mg/l", "mg/l", "mg/l", "mg/l", "mg/l", 
"mg/l", "mg/l", "mg/l", "mg/l", "mg/l", "mg/l", "mg/l", "mg/l", 
"mg/l", "mg/l", "mg/l", "mg/l", "mg/l", "mg/l", "mg/l", "mg/l", 
"mg/l", "mg/l", "mg/l", "mg/l", "mg/l", "mg/l", "mg/l", "mg/l", 
"mg/l", "mg/l", "mg/l", "mg/l", "mg/l", "mg/l", "mg/l", "mg/l", 
"mg/l", "mg/l", "mg/l"), HUC14 = c("02040301030050", "02040301040020", 
"02040301030050", "02030104050040", "02040301020050", "02020007020030", 
"02040206130020", "02040301030050", "02040105040040", "02040301030010", 
"02030105020030", "02030103140040", "02040301030050", "02030104090040", 
"02040202160010", "02040301020050", "02040301030050", "02040301030040", 
"02040301030050", "02030105140020", "02040105070040", "02040301030040", 
"02040301030050", "02040202120010", "02040301030050", "02030103040010", 
"02040206080040", "02040301020050", "02040301030030", "02040105050050", 
"02040301200110", "02040202060040", "02040301020020", "02040105080020", 
"02040301020050", "02040105240060", "02040301030010", "02040301030050", 
"02030103050060", "02040301080050"), WMA = c("13", "13", "13", 
"7", "13", "2", "17", "13", "1", "13", "8", "4", "13", "12", 
"18", "13", "13", "13", "13", "9", "1", "13", "13", "18", "13", 
"6", "17", "13", "13", "1", "14", "19", "13", "1", "13", "11", 
"13", "13", "3", "13"), year = c(2018L, 2009L, 2008L, 2008L, 
2017L, 2014L, 2017L, 2007L, 2018L, 2013L, 2008L, 2004L, 2012L, 
2007L, 2004L, 2008L, 2014L, 2017L, 2008L, 2003L, 2005L, 2007L, 
2015L, 2005L, 2012L, 2015L, 2013L, 2011L, 2014L, 2001L, 2004L, 
2011L, 2012L, 2011L, 2016L, 2010L, 2009L, 2011L, 2006L, 2004L
)), .Names = c("stdate", "sttime", "locid", "charnam", "val", 
"valunit", "HUC14", "WMA", "year"), row.names = c(NA, -40L), class = c("tbl_df", 
"tbl", "data.frame"))

UI

library(shiny)
library(shinydashboard)
library(tidyverse)
library(plotly)
header<-dashboardHeader(title="test app")
sidebar<-dashboardSidebar(selectInput("huc","Please Select HUC14:",choices=df$HUC14,selected = df$HUC14))
body<- dashboardBody(plotlyOutput("plot"))
ui <- dashboardPage(header = header,
sidebar = sidebar,
body = body)

服务器：

server<- function(input,output,session) {
df_reac<-reactive({
df%>%
filter(HUC14 == input$huc)
})
output$plot<-renderPlotly({
ggplot(df_reac(), aes(x = year, y = val)) +
geom_point(aes(color="Discrete"),size=3) +
geom_hline(aes(yintercept = 500,color="Freshwater Aquatic Life Criterianfor TDS = 500 mg/L"),size=1.3)+
xlab("Year") + ylab(" TDS Concentration (mg/L)")})

observeEvent(input$huc,{
plotlyProxy("plot",session)%>%
plotlyProxyInvoke("relayout")
})
}
shinyApp(ui,server)

我实际使用的数据超过了300000次观测，而这个应用程序要复杂得多。。但我会用这个来保持它的简短和甜蜜。我希望这足以作为一个可复制的例子。。如果没有，请告诉我！

Answer 1

下面的shinyApp显示了如何将plotlyProxyInvoke与方法relayout、restyle、addTraces、deleteTraces和moveTraces一起使用。

您实际上并没有plotly对象，因为您没有将ggplot对象封装在ggplotly调用中。我还包含了highlight_key函数，尽管对于本例来说它并不是真正必要的。

• Relayout发生在放大时，例如，这将把标题和yaxis.range更改为0-500。你可以在这里找到一个更有趣的重新连接方法。

• Restyle1方法在单击橙色点时发生，该方法将不透明度更改为0.1，标记颜色更改为蓝色，线条颜色更改为橙色。

• 使用"长方体/套索选择"时将发生"Restyle 2"，该操作将不透明度更改回1，标记颜色更改为红色，线条颜色更改为蓝色。

• AddTraces发生在将鼠标悬停在点(或其他轨迹(上时，这将添加一个随机轨迹。

• DeleteTraces在单击按钮(delete(时发生，这将删除数据数组中的最后一个跟踪。

• MoveTraces发生在单击按钮(move(时，这将更改索引为0&1，并将它们附加到数据数组的末尾。

要查看可以调用的所有可用方法，请输入：

plotly:::plotlyjs_methods()
[1] "restyle"       "relayout"      "update"        "addTraces"     "deleteTraces"  "moveTraces"    "extendTraces"  "prependTraces"               
[9] "purge"         "toImage"       "downloadImage" "animate"

有关进一步的解释，请查看Plotly参考和这个shinyApp示例。

---

ui.R

library(shiny)
library(shinydashboard)
library(tidyverse)
library(plotly)
header<-dashboardHeader(title="test app")
sidebar<-dashboardSidebar(selectInput("huc","Please Select HUC14:",choices=df$HUC14,selected = df$HUC14),
actionButton("delete", "Delete the last trace"),
actionButton("move", " Move traces"))
body<- dashboardBody(plotlyOutput("plot"))
ui <- dashboardPage(header = header,
sidebar = sidebar,
body = body)

服务器.R

server<- function(input,output,session) {
df_reac<-reactive({
df%>%
filter(HUC14 == input$huc)
})
output$plot<-renderPlotly({
key = highlight_key(df_reac())
p <- ggplot(key, aes(x = year, y = val)) +
geom_point(aes(color="Discrete"),size=3) +
geom_hline(aes(yintercept = 500,color="Freshwater Aquatic Life Criterianfor TDS = 500 mg/L"),size=1.3)+
xlab("Year") + ylab(" TDS Concentration (mg/L)")
ggplotly(p)
})
observeEvent(event_data("plotly_relayout"), {
print("relayout")
plotlyProxy("plot", session) %>%
plotlyProxyInvoke("relayout", list(title = 'New title', 
yaxis.range = list(0,500)))
})
observeEvent(event_data("plotly_click"), {
print("restyle 1")
plotlyProxy("plot", session) %>%
plotlyProxyInvoke("restyle", list(opacity=0.1, marker.color="blue", line.color="orange"))
})
observeEvent(event_data("plotly_selected"), {
print("restyle 2")
plotlyProxy("plot", session) %>%
plotlyProxyInvoke("restyle", list(opacity=1, marker.color="red", line.color="blue"))
})
observeEvent(event_data("plotly_hover"), {
print("addTraces")
time = as.numeric(format(df_reac()$stdate, "%Y"))
plotlyProxy("plot", session) %>%
plotlyProxyInvoke("addTraces", list(y = as.list(sort(sample(100:500, 3, F))), 
x = as.list(sort(sample(seq(time-0.05,time+0.05, by = 0.02), 3, F)))))
})
observeEvent(input$delete, {
print("deleteTraces")
plotlyProxy("plot", session) %>%
plotlyProxyInvoke("deleteTraces", list(-1))
})
observeEvent(input$move, {
print("moveTraces")
plotlyProxy("plot", session) %>%
plotlyProxyInvoke("moveTraces", list(0, 1))
}) 
}
shinyApp(ui,server)