Использование функции Shiny actionButton() в функции onRender() htmlWidgets

У меня есть приложение Shiny, в котором пользователь может выбирать черные точки на диаграмме рассеяния Plotly с помощью значка Plotly "box select". Точки, выбранные пользователем, будут выделены красным цветом. У меня есть MWE этого приложения ниже:

library(plotly)
library(htmlwidgets)
library(shiny)

ui <- shinyUI(fluidPage(
  plotlyOutput("myPlot")
))

server <- shinyServer(function(input, output) {
  p <- ggplot(mtcars, aes(x = wt, y = mpg))  + xlim(10,40) +ylim(0,10)
  ggPS <- ggplotly(p)

  output$myPlot <- renderPlotly(ggPS %>%
    onRender("
       function(el, x, data) {

       var xArr = [];
       var yArr = [];
       for (a=0; a<data.wt.length; a++){
       xArr.push(data.wt[a])
       yArr.push(data.mpg[a])
       }

       Traces=[]
       var tracePoints = {
         x: yArr,
         y: xArr,
         hoverinfo: 'none',
         mode: 'markers',
         marker: {
           color: 'black',
           size: 4
         }
       };
       Traces.push(tracePoints);
       Plotly.addTraces(el.id, Traces);

       el.on('plotly_selected', function(e) {
       var numSel = e.points.length
       var xSel = [];
       var ySel = [];

       for (a=0; a<numSel; a++){
         xSel.push(e.points[a].x)
         ySel.push(e.points[a].y)
       }

       var trace = {
         x: xSel,
         y: ySel,
         mode: 'markers',
         marker: {
           color: 'red',
           size: 4
         },
         hoverinfo: 'none'
       };

       Traces.push(trace);
       Plotly.addTraces(el.id, Traces);
       })

       }
       ", data = list(dat= mtcars, wt=mtcars$wt, mpg=mtcars$mpg)))})

shinyApp(ui, server)

Я сейчас пытаюсь обновить это блестящее приложение, чтобы выбранные черные точки автоматически не становились красными. Вместо этого, после того, как пользователь выберет черные точки, он может нажать на кнопку действия с меткой "Выделить выбранные точки". Если пользователь нажимает эту кнопку действия, выбранные точки становятся красными. Ниже моя попытка заставить это работать. К сожалению, это приложение не работает, и фактически теряет свою функциональность рисования оригинальных черных точек и, в первую очередь, предоставления значка выбора поля.

library(plotly)
library(Shiny)
library(htmlwidgets)

ui <- shinyUI(fluidPage(
  plotlyOutput("myPlot"),
  actionButton("highlight", "Highlight selected points")
))

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

  highlight <- reactive(input$highlight)

  p <- ggplot(mtcars, aes(x = wt, y = mpg))  + xlim(10,40) +ylim(0,10)
  ggPS <- ggplotly(p)

  output$myPlot <- renderPlotly(ggPS %>%
onRender("
   function(el, x, data) {

   var xArr = [];
   var yArr = [];
   for (a=0; a<data.wt.length; a++){
   xArr.push(data.wt[a])
   yArr.push(data.mpg[a])
   }

   Traces=[]
   var tracePoints = {
   x: yArr,
   y: xArr,
   hoverinfo: 'none',
   mode: 'markers',
   marker: {
   color: 'black',
   size: 4
   }
   };
   Traces.push(tracePoints);
   Plotly.addTraces(el.id, Traces);

   el.on('plotly_selected', function(e) {

observeEvent(data.highlightS, {
   var numSel = e.points.length
   var xSel = [];
   var ySel = [];
   for (a=0; a<numSel; a++){
   xSel.push(e.points[a].x)
   ySel.push(e.points[a].y)
   }

   var trace = {
   x: xSel,
   y: ySel,
   mode: 'markers',
   marker: {
   color: 'red',
   size: 4
   },
   hoverinfo: 'none'
   };
   Traces.push(trace);
   Plotly.addTraces(el.id, Traces);
})
   })

   }
   ", data = list(dat= mtcars, wt=mtcars$wt, mpg=mtcars$mpg, highlightS=highlight())))})

shinyApp(ui, server)

РЕДАКТИРОВАТЬ:

Я хотел включить картинку, чтобы продемонстрировать, к чему я стремлюсь. В основном, если пользователь выбирает 15 точек, показанных ниже, они остаются черными:

Однако, если пользователь выбирает блестящую кнопку "Выделить выделенные точки", то 15 точек станут красными, как показано ниже:

Выделены красные точки

Источник

2 ответа

Это был бы предпочтительный способ сделать это, но другое решение, которое я предоставил, работает лучше. Это из-за сюжетной ошибки в R-привязке, которая разбрасывает значения ключа при выделении, поэтому он работает только для одной итерации. После выбора значения ключа больше не будут работать. Если вы попробуете это, вы поймете, что я имею в виду.

Также я не мог заставить работать размеры, как указано выше, это также может быть еще одна ошибка или просто странная проблема дизайна.

Тем не менее, я предоставляю его в любом случае, потому что он, вероятно, когда-нибудь сработает, и это лучшее решение, требующее гораздо меньшего количества кода - или, возможно, кто-то предложит хороший обходной путь для этого.

library(plotly)
library(htmlwidgets)
library(shiny)
library(shinyBS)
library(ggplot2)

ui <- shinyUI(fluidPage(
  plotlyOutput("myPlot"),
  bsButton("high","Highlight Selected Points",type="toggle")
))

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

  m <- mtcars
  m$selected <- 0
  m$key <- 1:nrow(m)

  rv <- reactiveValues(m=m,high=FALSE)

  observeEvent(input$high,{req(input$high);rv$high <- !rv$high } )

  ggPS <- reactive(ggplotly(ggplot(m, aes(x = wt, y = mpg))))

  sel <- reactive(event_data("plotly_selected"))

  mvis <- reactive({
    rv$high
    sdatf <- sel()
    isolate({
      rv$m$selected <- 0L 
      rv$m$selected[ sdatf$key ] <- 1L  # now select the ones in sdatf
    })
    print(sdatf)  # debugging
    return(rv$m)
  })

  output$myPlot <- renderPlotly({
    mvf <- mvis()
    mvf$selfac <- factor(mvf$selected,levels=c(0L, 1L))
    print(mvf)
    highcol <- ifelse(rv$high,"red","black")
    clrs <-  c("black",highcol)
    ggPS() %>%  add_markers(data=mvf,x=~wt,y=~mpg,key=~key, 
                            color=~selfac,colors=clrs) %>%
                layout(dragmode = "select")
    })
})

shinyApp(ui, server)
Источник

Хорошо, это то, что вы хотите, я думаю.

Мне пришлось использовать другой подход, так как я не думаю, что вы можете добавить заговор el.on событие, как это, но на самом деле сюжет имеет блестящий event_data("plotly_selected") конструкция предназначена только для такого рода вещей - так что я использовал это вместо.

Основные изменения, которые я сделал:

  • сохранил фрейм данных, с которым мы работаем (m) в reactiveValues так что вы можете легко получить к нему доступ (без использования << -) из реактивного узла.
  • добавил reactive(event_data(.. чтобы получить блестящие данные выбора.
  • добавил selected колонке к нашему рабочему фрейму данных, чтобы отслеживать то, что должно быть отмечено красным.
  • добавил reactive узел (mvis) для обработки выбранных данных по мере их поступления и пометки новых вещей как выбранных. Также изолировал узел от события responsetiveValue isolate чтобы избежать бесконечной цепочки реакций.
  • избавился от el.on(plotly_selected потому что я не вижу, как это могло бы работать (хотя, вероятно, есть способ).
  • включил выбор маркеров с layout(dragmode="select") вызов
  • добавлен второй след для черных маркеров, один для выбранных
  • добавили ключевую переменную, чтобы мы могли отслеживать, как нанесенные маркеры соответствуют нашим строкам данных.
  • и несколько других мелких мелких изменений (xArr а также yArr были перепутаны в оригинале traceBlock определение например)
  • добавлена ​​кнопка переключения начальной загрузки, чтобы выделить селектор (как позже будет запрошено). Обратите внимание, что для переключения требуется двойной щелчок.

Итак, вот код:

library(plotly)
library(htmlwidgets)
library(shiny)
library(shinyBS)
library(ggplot2)

ui <- shinyUI(fluidPage(
  plotlyOutput("myPlot"),
  bsButton("high","Highlight Selected Points",type="toggle")
))

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

  m <- mtcars
  m$selected <- 0

  rv <- reactiveValues(m=m,high=FALSE)

  observeEvent(input$high,{req(input$high);rv$high <- !rv$high } )

  ggPS <- reactive(ggplotly(ggplot(m, aes(x = wt, y = mpg))))

  sel <- reactive(event_data("plotly_selected"))

  mvis <- reactive({
    rv$high
    sdatf <- sel()
    print(rv$high)
    isolate({
      rv$m$selected <- 0 
      rv$m$selected[ sdatf$key ] <- 1  # now select the ones in sdatf
    })
    #  print(sdatf)  # debugging
    return(rv$m)
  })

  jscode <- 
 "function(el, x, data) {
    Traces=[]
    var xArrNrm = [];
    var yArrNrm = [];
    var idxNrm = [];
    var xArrSel = [];
    var yArrSel = [];
    var idxSel = [];
    for (a=0; a<data.mvis.length; a++){
      if(data.mvis[a]['selected']===0){
        xArrNrm.push(data.mvis[a]['wt'])
        yArrNrm.push(data.mvis[a]['mpg'])
        idxNrm.push(a+1)
      } else {
        xArrSel.push(data.mvis[a]['wt'])
        yArrSel.push(data.mvis[a]['mpg'])
        idxSel.push(a+1)
      }
    }
    console.log(data.mvis.length)
    console.log(data)
    var tracePointsNrm = {
      x: xArrNrm,
      y: yArrNrm,
      key: idxNrm,
      hoverinfo: 'none',
      mode: 'markers',
      marker: {
        color: 'black',
        size: 4
      }
    };
    var tracePointsSel = {
      x: xArrSel,
      y: yArrSel,
      key: idxSel,
      hoverinfo: 'none',
      mode: 'markers',
      marker: {
        color: 'red',
        size: 6
      }
    };
    if (!data.high){
       tracePointsSel.marker.color = 'black'
    }
    //   console.log(tracePointsNrm) // debuging 
    //   console.log(tracePointsSel)
    Traces.push(tracePointsNrm);
    Traces.push(tracePointsSel);
    Plotly.addTraces(el.id, Traces);
 }"
  output$myPlot <- renderPlotly({
                    ggPS() %>%  onRender(jscode,data=list(mvis=mvis(),high=rv$high)) %>%
                                layout(dragmode = "select")
                    })
})
shinyApp(ui, server)

И вот снимок экрана:

Замечания:

Это кажется слишком сложным, и это так. Теоретически это можно сделать без использования onRender и любой JavaScript, добавив следы с add_marker и настройка key приписывать. К сожалению, в привязке R, похоже, есть заговор, который скремблирует значения ключей после выбора, когда вы делаете это таким образом. Слишком плохо - это было бы намного короче и легче для понимания - возможно, это будет в конечном счете исправлено.

Источник
Другие вопросы по тегам