r - 设置一个绘图缩放以匹配 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)