在 event_data 中使用 plotly 动画帧

Question

我正在尝试根据动画情节图中的选定帧过滤闪亮的情节（对于这个应用程序：http://www.seabbs.co.uk/shiny/ExploreGlobalTB/#）。这是否可以使用当前的 event_data 实现（供参考：https://plotly-book.cpsievert.me/linking-views-with-shiny.html）？通过阅读ropensci GitHub，我认为这还没有实现。如果没有其他获得此功能的建议？

图之间反应性的工作示例（点击时）如下（警告此代码使用 getTBinR 并将从此处提取 WHO TB 数据 (http://www.who.int/tb/country/data/download/en/)。

#install.packages(shiny)
library(shiny)
# install.packages(devtools)
# devtools::install_github("seabbs/getTBinR", ref = "improved_interactive_plots")
library(getTBinR)

ui <- fluidPage(
  plotlyOutput("map_tb_burden"),
  verbatimTextOutput("country")
)

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

# Make map of metric
output$map_tb_burden <- renderPlotly({

  map <- map_tb_burden(interactive = TRUE, year = c(2000:2016))

})

#Get country clicked on map
country <- reactive({
  country <- event_data(event = "plotly_click", source = "WorldMap")

  country <- country$key[[1]]
})

output$country <- renderText({
  if (is.null(country())) {
    "Select a country for more information"
  } else {
    paste0("Showing data for ", country())
  }
})

  }

shinyApp(ui, server)

此数据的框架是 ggplot 对象中的 Year，然后使用 plotly 进行转换（映射函数代码：https://github.com/seabbs/getTBinR/blob/improved_interactive_plots/R/map_tb_burden.R）。理想情况下，我可以使用 event_data 框架，但如果不这样做，是否可以从 plotly 对象中选择当前帧？

根据 MLavoie 的回答修改的第二个示例。只是为了澄清目的是在动画结束时提取点击国家和年份。这两个示例都在点击时提取国家/地区，以下内容清楚地表明年份并没有随着动画而动态变化。

library(shiny)
library(plotly)
library(getTBinR)

tb_burden <- get_tb_burden()

ui <- fluidPage(
  plotlyOutput("map_tb_burden"),
  dataTableOutput("country")
)

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

  # Make map of metric
  output$map_tb_burden <- renderPlotly({


    key <- tb_burden$iso3

    g <- list(
      showframe = FALSE,
      showcoastlines = FALSE,
      projection = list(type = 'Mercator')
    )


    plot_ly(data  = tb_burden, frame = ~year, type = 'choropleth', z = ~e_inc_100k, text = ~country, color = ~e_inc_100k, colors = "Reds", locations = ~iso3, key = key) %>% 
      layout(geo = g)

  })

  #Get country clicked on map
  countryB <- reactive({
    d <- event_data("plotly_click")
    ff <- data.frame(d[3])
    ff
  })



  output$country <- renderDataTable({

    d <- event_data("plotly_click")

    #   if (is.null(d))
    #    return(NULL)

    withProgress(message = 'Click on a country', {
      validate(
        need(d, 'Click on a country!')
      )



      testing <- tb_burden %>% filter(iso3 == countryB()$key) 
      testing

    })

  })


}

shinyApp(ui, server)

Answer 1

我仍然不确定你想要什么，但这里有一些东西。我没有使用map_tb_burden，而是使用plot_ly 作为图形。在示例中，它只打印文本，但您可以决定改为打印。

library(shiny)
library(plotly)
library(getTBinR)

tb_burden <- get_tb_burden()

ui <- fluidPage(
  plotlyOutput("map_tb_burden"),
  sliderInput("animation", "Looping Animation:", min = 2000, max = 2016, value = 2000, step = 1, animate= animationOptions(interval=1000, loop=FALSE, playButton = "PLAY", pauseButton = "PAUSE")),
  dataTableOutput("country")
)

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

  # Make map of metric
  output$map_tb_burden <- renderPlotly({


    key <- tb_burden$iso3

    g <- list(
      showframe = FALSE,
      showcoastlines = FALSE,
      projection = list(type = 'Mercator')
    )

    tb_burdenb <- tb_burden %>% filter(year == input$animation) 
    key <- tb_burdenb$iso3

    plot_ly(data  = tb_burdenb, type = 'choropleth', z = ~e_inc_100k, text = ~country, color = ~e_inc_100k, colors = "Reds", locations = ~iso3, key = key) %>% 
      layout(geo = g)

  })



  sliderValues <- reactive({

    # Compose data frame
    data.frame(
      Name = c("Animation"),
      Value = as.character(c(input$animation)), 
      stringsAsFactors=FALSE)
  }) 



  #Get country clicked on map
  countryB <- reactive({
    d <- event_data("plotly_click")
    ff <- data.frame(d[3])
    ff
  })



  output$country <- renderDataTable({

    d <- event_data("plotly_click")

    #   if (is.null(d))
    #    return(NULL)

    withProgress(message = 'Click on a country', {
      validate(
        need(d, 'Click on a country!')
      )



      testing <- tb_burden %>% filter(iso3 == countryB()$key) %>% filter(year == input$animation) 
      testing

    })

  })


}

shinyApp(ui, server)