在event_data中使用繪圖動畫幀

Question

我正在嘗試根據動畫情節情節中的選定幀來過濾閃亮的情節（對於此應用程序： http : //www.seabbs.co.uk/shiny/ExploreGlobalTB/# ）。 使用當前的event_data實現是否可行（供參考： https ://plotly-book.cpsievert.me/linking-views-with-shiny.html）？ 通過閱讀ropnsci 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)