使用按钮更改 Plotly 突出显示

Question

我正在用 Plotly 绘制时间序列，点击某个 column/day，会发生一些特殊事件。现在我还想使用导航按钮（下一天/前一天）来更改所选日期。

问题是突出显示仍然在图中单击的列上，因此与单击导航按钮时实际选择的日期不同。

如何使用 actionButtons 更改 Plotly 的突出显示？

或

如何使用 actionButons 模拟对 Plotly 列的点击？

测试应用程序：

## Libs##########
library(shiny)
library(ggplot2)
library(plotly)
library(data.table)

## Data ############
dfN <- data.table(
  time_stamp = seq.Date(as.Date("2018-04-01"), as.Date("2018-07-30"), 1),
  val = runif(121, 100,1000),
  qual = 8,
  col = "green", stringsAsFactors = F
)
setkey(dfN, time_stamp)

Rnd <- sample(1:nrow(dfN), size = 10, replace = F)
dfN[Rnd,"col"] <- "red"
dfN[Rnd, "qual"] <- 3

## Ui ##########
ui <- fluidPage(
  plotlyOutput("plot"),
  h4("Which Day is selected:"),
  verbatimTextOutput("selected"),
  actionButton("prev1", "Previous Element"),
  actionButton("next1", "Next Element")
)

## Server ##########
server <- function(input, output, session) {
  ## Plot
  output$plot <- renderPlotly({
    key <- highlight_key(dfN)
    p <- ggplot() +
      geom_col(data = key, aes(x = plotly:::to_milliseconds(time_stamp), y = val, fill=I(col),
                               text=paste("Date: ", time_stamp, "<br>",
                                          "Quality: ", qual))) +
      labs(y = "", x="") +
      theme(legend.position="none")

    ggplotly(p, source = "Src", tooltip = "text") %>% 
      layout(xaxis = list(tickval = NULL, ticktext = NULL, type = "date")) %>% 
      highlight(selectize=F, off = "plotly_doubleclick", on = "plotly_click", color = "blue",
                opacityDim = 0.5, selected = attrs_selected(opacity = 1))
  })

  ## Selected Day reactive
  SelectedDay <- reactiveVal(NULL)

  ## Plotly Event for clicks
  observe({
    s <- event_data("plotly_click", source = "Src")
    req(s)
    SelectedDay(as.Date(s$x))
  })

  ## Action buttons for next / previous Day
  observeEvent(input$next1, {
    IND <- which(dfN$time_stamp == SelectedDay()) + 1
    if (IND >= length(dfN$time_stamp)) {
      IND = length(dfN$time_stamp)
      print("last element reached")
    }
    SelectedDay(dfN[IND,time_stamp])
  })
  observeEvent(input$prev1, {
    IND <- which(dfN$time_stamp == SelectedDay()) - 1
    if (IND <= 1) {
      print("first element reached")
      IND = 1
    }
    SelectedDay(dfN[IND,time_stamp])
  })

  ## Print the actual selection
  output$selected <- renderPrint({
    req(SelectedDay())
    SelectedDay()
  })
}

shinyApp(ui, server)

Answer 1

我需要放弃你的 ggplotly()，但尽管如此，我还是会这样做：

## Libs##########
library(shiny)
library(plotly)
library(data.table)

## Data ############

dfN <- data.table(
  time_stamp = seq.Date(as.Date("2018-04-01"), as.Date("2018-07-30"), 1),
  val = runif(121, 100,1000),
  qual = 8,
  col = "green", stringsAsFactors = F
)
setkey(dfN, time_stamp)

Rnd <- sample(1:nrow(dfN), size = 10, replace = F)
dfN[Rnd,"col"] <- "red"
dfN[Rnd, "qual"] <- 3

## Ui ##########
ui <- fluidPage(
  plotlyOutput("plot"),
  h4("Which Day is selected:"),
  verbatimTextOutput("selected"),
  actionButton("prev1", "Previous Element"),
  actionButton("next1", "Next Element")
)

## Server ##########
server <- function(input, output, session) {
  ## Plot
  output$plot <- renderPlotly({
    plot_ly(dfN, source = "Src", x=~time_stamp, y=~val, selectedpoints=as.list(which(dfN$time_stamp==SelectedDay())-1), type = "bar")
  })

  ## Selected Day reactive
  SelectedDay <- reactiveVal(dfN$time_stamp[1])

  ## Plotly Event for clicks
  observe({
    s <- event_data("plotly_click", source = "Src")
    req(s)
    SelectedDay(as.Date(s$x))
  })

  ## Action buttons for next / previous Day
  observeEvent(input$next1, {
    IND <- which(dfN$time_stamp == SelectedDay()) + 1
    if (IND >= length(dfN$time_stamp)) {
      IND = length(dfN$time_stamp)
      print("last element reached")
    }
    SelectedDay(dfN[IND,time_stamp])
  })
  observeEvent(input$prev1, {
    IND <- which(dfN$time_stamp == SelectedDay()) - 1
    if (IND <= 1) {
      print("first element reached")
      IND = 1
    }
    SelectedDay(dfN[IND,time_stamp])
  })

  ## Print the actual selection
  output$selected <- renderPrint({
    req(SelectedDay())
    SelectedDay()
  })
}

shinyApp(ui, server)

也许您可以根据自己的需要进行调整。另请参阅：https://plot.ly/r/reference/#bar-selectedpoints

多个selectedpoints示例：

library(plotly)

singleP <- plot_ly(data.frame(x=1:10, y=1:10), x=~x, y=~y, selectedpoints=list(1,8), type = "bar")

multiP <- plot_ly(data.frame(x=1:10, y=1:10)) %>% 
  add_trace(x=~x, y=~y, selectedpoints=list(1,8), type = "bar") %>% 
  add_trace(x=~x, y=~y, selectedpoints=list(0,2,6), type = "bar")

subplot(singleP, multiP)

使用按钮更改 Plotly 突出显示

Change Plotly highlight with Buttons

javascript

r

shiny

plotly

r-plotly