如何在带有ggplotly（）的闪亮应用程序中使用plotlyProxy（）以使绘图更快地呈现

时间：2018-12-04 14:01:53

标签： r plotly r-plotly ggplotly

我一直在寻找一个与此相关的问题，但我还没有看到任何问题。.我正在创建一个闪亮的应用程序，该应用程序使用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)

我实际使用的数据超过300,000次观察，并且该应用程序更加复杂..但是我将使用它来使其简短而优美。我希望这足以作为一个可重复的示例。如果没有，请告诉我！

1 个答案:

答案 0 :(得分：2)

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

由于没有将ggplot对象包装在ggplotly调用中，因此您实际上并没有一个plotly对象。我也包含了highlight_key函数，尽管对于这个示例来说并不是必须的。

    例如，当您放大时，会发生

  • 重新布局，这会将Title和yaxis.range更改为0-500。您可以在此{{3 }}。

    • 当单击橙色点时，会发生

  • Restyle 1 方法，该方法将将不透明度更改为0.1，将标记颜色更改为蓝色，并将线条颜色更改为橙​​色。

    < / li>

  • 重设样式2 会在您使用Box / Lasso-Select时发生，它将不透明度更改为1，标记颜色更改为红色，线条颜色更改为蓝色。

    • 将鼠标悬停在该点（或其他轨迹）上时会发生

  • AddTraces ，这会添加随机轨迹。

    • 单击按钮（delete时会发生

  • DeleteTraces ，这将删除数据数组中的最后一条迹线。

    • 单击按钮（move）会发生

  • MoveTraces ，这将更改索引为0和1的迹线的顺序，并将其附加到数据数组的末尾。

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

plotly:::plotlyjs_methods()

[1] "restyle"       "relayout"      "update"        "addTraces"     "deleteTraces"  "moveTraces"    "extendTraces"  "prependTraces"               
[9] "purge"         "toImage"       "downloadImage" "animate"

有关更多说明，请查看github-example和此Plotly reference。

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)
相关问题
最新问题