在 Shiny 中设置一个绘图缩放以匹配另一个绘图缩放

Question

我正在尝试使用 plotly_relayout 来获取一个绘图的 x 轴缩放限制，并将它们应用于 Shiny 中的另一个绘图。到目前为止，我可以从“plot1”（x 轴范围）获取相关的 plotly_relayout 数据，将其转换（从数字到日期），并在绘制“plot2”之前使其可用，但它实际上并没有设置缩放“plot2”上的范围。

在大多数情况下，当我尝试放大“plot1”时，我的 RStudio 就会崩溃。只有在 RStudio 没有崩溃的少数情况下，我才看到“plot2”中的“coord_cartesian”没有达到预期的效果（放大 plot1 后）。

我也很好奇我的 RStudio 持续崩溃是否正常，或者我可能需要考虑重新构建 RStudio。任何有关如何实现此效果的想法都将不胜感激！

library(ggplot2)
library(plotly)
library(shinydashboard)
library(shinyWidgets)

#Data frame with dates and bogus data
a=data.frame(Date=seq.Date(as.Date("2000-01-01"),
                           as.Date("2000-12-31"),
                           "day"),
             value=rnorm(366)
             )

#Simple dashboard with two plots
ui <- dashboardPage(
  dashboardHeader(title="Sample App"),
  dashboardSidebar(
  ),
  dashboardBody(
    plotlyOutput("plot1"),
    plotlyOutput("plot2")
  )
)

server <- function(input, output, session){

  #Create a reactive list, set zoomX1 and zoomX2 as NULL
  reactiveList <- reactiveValues(zoomX1=NULL,zoomX2=NULL)

  #Create a reactive function to update the reactive list every time the plotly_relayout changes
  relayout_data <- reactive({
    xvals=event_data("plotly_relayout",source="plot1")
    if (is.null(xvals$`xaxis.range[0]`)){
    } else {
      reactiveList$zoomX1=as.Date(xvals$`xaxis.range[0]`,origin="1970-01-01")
      reactiveList$zoomX2=as.Date(xvals$`xaxis.range[1]`,origin="1970-01-01")
    }
  })

  #Plot1, just plot all the data
   output$plot1 <- renderPlotly({
    g1=ggplot(a,aes(x=Date,y=value))+
      geom_point()
    ggplotly(g1,source="plot1") %>% event_register("plotly_relayout")
  })

   #Plot 2, same as Plot1, but should set the coord_cartesian based on plot1's current zoom level taken from the event_data("plotly_relayout")
   output$plot2 <- renderPlotly({
     relayout_data()
     g1=ggplot(a,aes(x=Date,y=value))+
       geom_point()+
       coord_cartesian(xlim=c(reactiveList$zoomX1,reactiveList$zoomX2))
     ggplotly(g1,source="plot2")
   })

}

shinyApp(ui = ui, server = server)

Answer 1

实际上，在我的系统上，您的代码运行良好。

但是，您可以通过使用 plotly 的 subplot 函数和它的参数 shareX 来大幅减少代码。请检查以下示例：

library(ggplot2)
library(plotly)
library(shinydashboard)
library(shinyWidgets)

a <- data.frame(Date = seq.Date(as.Date("2000-01-01"),
                               as.Date("2000-12-31"),
                               "day"),
               value = rnorm(366))

ui <- dashboardPage(
  dashboardHeader(title = "Sample App"),
  dashboardSidebar(),
  dashboardBody(plotlyOutput("plots", height = "80vh"))
)

server <- function(input, output, session) {

  output$plots <- renderPlotly({
    g2 <- g1 <- ggplot(a, aes(x = Date, y = value)) +
      geom_point()

    subplot(ggplotly(g1), ggplotly(g2), nrows = 2, shareX = TRUE)
  })

}

shinyApp(ui = ui, server = server)