如何在shiny应用程序中使用plotlyProxy()和ggplotly()使绘图更快

Question

如何在shiny应用程序中使用plotlyProxy()和ggplotly()使绘图更快

7

我一直在寻找一个与此相关的问题，但我没有看到任何信息。我正在创建一个shiny应用程序，该应用程序使用ggplotly()使我的图形具有交互性。根据用户selectInput()下拉菜单，该图形是反应性的。一切都很好，但是当我在下拉菜单中点击新参数时，绘图需要很长时间才能呈现。通过查看这个问题，我发现了这篇文章Improving ggplotly conversions，它解释了为什么绘图需要很长时间（因为我有很多数据）。网站上说要使用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 Criteria\nfor 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)

我实际使用的数据超过30万条，该应用程序更加复杂。但是为了简短并易懂，我将使用这个示例。如果不够，请告诉我！

- NBE

1个回答

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- SeGa · Accepted Answer

下面的shinyApp展示了如何使用plotlyProxyInvoke方法，包括relayout，restyle，addTraces，deleteTraces和moveTraces。

您没有真正的plotly对象，因为您没有在ggplotly调用中包装ggplot对象。我还包括了highlight_key函数，尽管它对这个例子并不是必需的。

Relayout发生在您缩放时，例如，它将更改标题和y轴范围为0-500。您可以在此处找到一个更高级的relayout方法。
Restyle 1方法发生在单击橙色点时，它将把不透明度更改为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)

server.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 Criteria\nfor 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)