R сюжет: как наблюдать, скрыт ли след или показывается с помощью щелчков легенды на нескольких графиках - PullRequest
Новая
       50

R сюжет: как наблюдать, скрыт ли след или показывается с помощью щелчков легенды на нескольких графиках

0 голосов
/ 22 февраля 2019

Я пытаюсь выяснить, какие следы пользователь скрывает от точечного графика, отменив их выбор в интерактивной легенде о заговоре.

Я прочитал эту SO запись, и похожие вопросы, связанные в комментариях ниже, и это приблизило меня к решению

Текущее решение только частично выполняет то, чтоЯ нуждаюсь.Две вещи, которые я ищу, чтобы улучшить это: - как увидеть, какая легенда графика нажата (глядя на источник 'id'?) - Теперь я вижу, что нажата запись легенды, но мне нужно знать,он нажимается «ВКЛ» (показать трассировку) или «ВЫКЛ»

Выходной файл, который я ищу, будет выглядеть примерно так: input$trace_plot1: который представляет собой список всех отключенных трасс и которыеили один номер трассы на каждом клике, но это говорит о том, что эта конкретная трасса теперь включена или выключена

Цель для меня - связать визуальное скрытие и показ собзор всех моих групп в данных, где пользователь теперь может дать им новые имена, цвета и выбрать сохранение или удаление группы с помощью кнопки, за которой находится переключатель состояния T / F.Я хотел бы связать это состояние кнопок T / F с «показать» / «скрыть» следы от конкретного графика (так как в моем приложении есть 5 копий этих графиков, показывающих данные на разных этапах процесса анализа.

Вот моя попытка, которая каким-то образом не реагирует на легенду, только на zooom: 

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

js <- c(
  "function(el, x){",
  "  el.on('plotly_legendclick', function(evtData) {",
  "    Shiny.setInputValue('trace', evtData.data[evtData.curveNumber].name);",
  "  });",
  "}")

iris$group <- c(rep(1,50), rep(2, 50), rep(3,50))

ui <- fluidPage(
  plotlyOutput("plot1"),
  plotlyOutput("plot2"),
  verbatimTextOutput("legendItem")

)


server <- function(input, output){

  output$plot1 <- renderPlotly({
    p <- plot_ly(source = 'plotly1', data = iris, x = ~Sepal.Length, y = ~Petal.Length, color = ~as.factor(group), type = 'scatter', mode = 'markers') %>%
      layout(showlegend = TRUE)

    p %>% onRender(js)

    })

  output$plot2 <- renderPlotly({
    p <- plot_ly(source = 'plotly2', data = iris, x = ~Sepal.Length, y = ~Petal.Length, color = ~as.factor(group), type = 'scatter', mode = 'markers') %>%
      layout(showlegend = TRUE)

    p %>% onRender(js)

  })

  output$legendItem <- renderPrint({
    d <- input$trace
    if (is.null(d)) "Clicked item appear here" else d
  })

  }

shinyApp(ui = ui, server = server)

РЕДАКТИРОВАТЬ: РАБОТАЮЩЕЕ РЕШЕНИЕ, СПАСИБО НА БОЛЬШОЙ ОТВЕТ от SL 

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

js <- c(
  "function(el, x, inputName){",
  "  var id = el.getAttribute('id');",
  "  var d3 = Plotly.d3;",
  "  el.on('plotly_restyle', function(evtData) {",
  "    var out = {};",
  "    d3.select('#' + id + ' g.legend').selectAll('.traces').each(function(){",
  "      var trace = d3.select(this)[0][0].__data__[0].trace;",
  "      out[trace.name] = trace.visible;",
  "    });",
  "    Shiny.setInputValue(inputName, out);",
  "  });",
  "}")


ui <- fluidPage(
  plotlyOutput("plot1"),
  plotlyOutput("plot2"),
  verbatimTextOutput("tracesPlot1"),
  verbatimTextOutput("tracesPlot2")
)

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

output$plot1 <- renderPlotly({
    p1 <- plot_ly()
    p1 <-  add_trace(p1, data = mtcars, x = ~disp, y = ~mpg, type = 'scatter', mode = 'markers', color = ~as.factor(cyl))
    p1 %>% onRender(js, data = "tracesPlot1")    
  })

  output$plot2 <- renderPlotly({
    p2 <- plot_ly()
    p2 <- add_trace(p2, data = mtcars, x = ~disp, y = ~mpg, type = 'scatter', mode = 'markers', color = ~as.factor(cyl))
    p2 %>% onRender(js, data = "tracesPlot2")  })


  output$tracesPlot1 <- renderPrint({ unlist(input$tracesPlot1)  })

  output$tracesPlot2 <- renderPrint({unlist(input$tracesPlot2)
  })

}

shinyApp(ui, server)

1 Ответ

0 голосов
/ 22 февраля 2019

Помогает ли это? 

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

js <- c(
  "function(el, x){",
  "  el.on('plotly_legendclick', function(evtData) {",
  "    Shiny.setInputValue('trace', evtData.data[evtData.curveNumber].name);",
  "  });",
  "  el.on('plotly_restyle', function(evtData) {",
  "    Shiny.setInputValue('visibility', evtData[0].visible);",
  "  });",
  "}")

ui <- fluidPage(
  plotlyOutput("plot"),
  verbatimTextOutput("legendItem")
)

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

  output$plot <- renderPlotly({
    p <- plot_ly()
    for(name in c("drat", "wt", "qsec"))
    {
      p = add_markers(p, x = as.numeric(mtcars$cyl), y = as.numeric(mtcars[[name]]), name = name)
    }
    p %>% onRender(js)
  })

  output$legendItem <- renderPrint({
    trace <- input$trace
    ifelse(is.null(trace), 
           "Clicked item will appear here",
           paste0("Clicked: ", trace, 
                  " --- Visibility: ", input$visibility)
    )
  })
}

shinyApp(ui, server)

enter image description here

EDIT

Существует проблема с предыдущим решением, когда одиндвойной щелчок на элементе легенды.Вот лучшее решение: 

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

js <- c(
  "function(el, x){",
  "  var d3 = Plotly.d3;",
  "  el.on('plotly_restyle', function(evtData) {",
  "    var out = {};",
  "    d3.select('g.legend').selectAll('.traces').each(function(){",
  "      var trace = d3.select(this)[0][0].__data__[0].trace;",
  "      out[trace.name] = trace.visible;",
  "    });",
  "    Shiny.setInputValue('traces', out);",
  "  });",
  "}")


ui <- fluidPage(
  plotlyOutput("plot"),
  verbatimTextOutput("legendItem")
)

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

  output$plot <- renderPlotly({
    p <- plot_ly()
    for(name in c("drat", "wt", "qsec"))
    {
      p = add_markers(p, x = as.numeric(mtcars$cyl), y = as.numeric(mtcars[[name]]), name = name)
    }
    p %>% onRender(js)
  })

  output$legendItem <- renderPrint({
    input$traces
  })
}

shinyApp(ui, server)

enter image description here

Если у вас есть несколько сюжетов, добавьте идентификатор сюжета в селекторе легенды и используйтефункция для генерации кода JavaScript: 

js <- function(i) { 
  c(
  "function(el, x){",
  "  var id = el.getAttribute('id');",
  "  var d3 = Plotly.d3;",
  "  el.on('plotly_restyle', function(evtData) {",
  "    var out = {};",
  "    d3.select('#' + id + ' g.legend').selectAll('.traces').each(function(){",
  "      var trace = d3.select(this)[0][0].__data__[0].trace;",
  "      out[trace.name] = trace.visible;",
  "    });",
  sprintf("    Shiny.setInputValue('traces%d', out);", i),
  "  });",
  "}")
}

Затем выполните p1 %>% onRender(js(1)), p2 %>% onRender(js(2)), ..., и вы получите информацию о видимости трасс в input$traces1, input$traces2,....

Другой способ - передать нужное имя в третьем аргументе функции JavaScript с помощью аргумента data onRender: 

js <- c(
  "function(el, x, inputName){",
  "  var id = el.getAttribute('id');",
  "  var d3 = Plotly.d3;",
  "  el.on('plotly_restyle', function(evtData) {",
  "    var out = {};",
  "    d3.select('#' + id + ' g.legend').selectAll('.traces').each(function(){",
  "      var trace = d3.select(this)[0][0].__data__[0].trace;",
  "      out[trace.name] = trace.visible;",
  "    });",
  "    Shiny.setInputValue(inputName, out);",
  "  });",
  "}")


p1 %>% onRender(js, data = "tracesPlot1")
p2 %>% onRender(js, data = "tracesPlot2")
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Похожие темы

...