如何使用 R shiny 中的 javascript 使用通用按钮 + selectInput 更改轨迹 n 的 plotly legendstatus

How to change plotly legendstatus of trace n with a generic button + selectInput through javascript in R shiny

感谢 this 上一个问题的回答,我开发了一个 plotly plotbuttons 链接到它的 legend,点击 legend 改变了 reactive variable 的状态,每个 T/F 状态都包含了 T/F 状态,因此重新呈现链接到每个 trace(数据组)的 actionbuttons。另一个 javascript 在相反的方向上做同样的事情,点击 button hides/shows trace + legendplot 中的项目。

现在我希望通过新按钮+选择输入添加另一个交互

问题简述:
如何点击通用按钮 (#0),
更改 TRUE/'legendonly'
之间的图例状态切换 对于 plotly plot j (#1) 的轨迹 n,
其中 n = input$SelectTrace (#2)
通过在 actionButton

上使用 javascript + onclick 参数

0 actionButton 在此处调用了 'SwitchExt'
1 它需要针对特定​​的 plotly plot 因为我有多个
2 a selectInput 以痕迹作为选择

详细解释:

现在我有以下小问题: 在我的应用程序中,在另一个条件面板中,向用户显示了一组具有相同数据的不同图表: - 用户可以选择要突出显示的轨迹,它旁边的按钮将根据 T/F 状态列表显示第一个图中的这条轨迹是否为 on/off,然后此按钮将显示 blue/red,并链接到选定的迹线。

场景: 用户选择组 n, 点击新的 actionButton 'SwitchExt' 这会触发 flipYNb_FP1(n), 操作按钮 YNbuttons... YNb <- YNElement(n) ....

if(values$dYNbs_cyl_el[[YNb]] == TRUE) {

将导致按钮 n 改变状态。

我可以让它也改变 values$legenditems[n],但是在我的情节代码中,values$legenditems 被包裹在 isolate({ }) 中以阻止情节在 [=24= 时重新渲染] 链接到 legend 更改它。

解决方案的概念: 基本上我认为我需要的不是直接更改 values$legenditems 列表,而是让另一块 javascript 通过 [=49= 链接到 actionButton 'switchExt' ] 并以 input$SelectTrace 作为输入,然后更改 legendstatus 类似于 javascript js1 的做法,但随后使用 document.getElementById 获取 input$SelectTrace 的值,将其变为 numeric,并更新 legendstatus

应用程序:

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

## js to link buttons to legend
js1 <- c(
  "function toggleLegend(id){",
  "  var ids = id.split('-');",
  "  var plotid = ids[1];",
  "  var plot = document.getElementById(plotid);",
  "  var data = plot.data;",
  "  var v0 = data[index].visible || true;",
  "  var v = v0 == true ? 'legendonly' : true;",
  "  Plotly.restyle(plot, {visible: v}, [index]);",
  "}")

## js code to link legend to buttons
js2 <- 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);",
  "  });",
  "}")



YNElement <-    function(idx){sprintf("YesNo-plot1-%d", idx)}


ui <- fluidPage(
  tags$head(
    tags$script(HTML(js1))
  ),
  fluidRow(
    column(2,
           h5("Keep/Drop choices linked to colorscheme 1"),
           uiOutput('YNbuttons')
    ),
    column(8,
           plotlyOutput("plot1")
    ),
    column(2,
           h5('Switch plot ID and shows the plot remembers the show/hide'),
           actionButton(inputId = 'Switch', label = icon('refresh'), style = "color: #f7ad6e;   background-color: white;  border-color: #f7ad6e;
                        height: 40px; width: 40px; border-radius: 6px;  border-width: 2px; text-align: center;  line-height: 50%; padding: 0px; display:block; margin: 2px"),
           br(),
           h5('New Button that does not work on legend.', style = 'font-weight:bold'),
            uiOutput('newswitch'),
           br(),
           selectInput(inputId = 'SelectTrace', label = 'Select Trace', choices = 1:3, selected = 1)
           ), style = "margin-top:150px"
    )

  )

server <- function(input, output, session) {
  values <- reactiveValues(Linked_FP1 = T, NrOfTraces = length(unique(mtcars$cyl)))

  observeEvent(input$SwitchExt, { 
    ## trying to make the user be able to switch the buttons linked to the legend on/off through another button that is in another page. 
    flipYNb_FP1(as.numeric(input$SelectTrace)) 
    req(values$legenditems)  ## don't run if legend items does not exist yet. 
    if(values$dYNbs_cyl_el[as.numeric(input$SelectTrace)]) { values$legenditems[[as.numeric(input$SelectTrace)]] <- T } else {   values$legenditems[[as.numeric(input$SelectTrace)]] <- 'legendonly' } ## problem line is here...... since I need to isolate values$legenditems in the plot code
    ## this does not actually cause the legend to change. If I don't isolate, the plot would re-render due to the change in values$legenditems, which is not what we want
  })




  output$plot1 <- renderPlotly({

    if(values$Linked_FP1) {colors <- c('red', 'blue', 'black') } else {colors <- c('black', 'orange', 'gray')}
    p1 <- plot_ly()
    p1 <-  add_trace(p1, data = mtcars, x = ~disp, y = ~mpg, type = 'scatter', mode = 'markers', color = ~as.factor(cyl), colors = colors)
    p1 <- layout(p1, title = 'mtcars group by cyl with switching colors')
    p1 <- plotly_build(p1)

   isolate({ if(values$Linked_FP1) { for(i in seq_along(p1$x$data)){   ## causes the plot to render with previous hide/show selection 
      p1$x$data[[i]]$visible <- values$legenditems[[p1$x$data[[i]]$name]]}  
    } }) ##This block is isolated because otherwise the plot will re-render when the user clicks 1 of the three buttons

    p1 %>% onRender(js2, data = "tracesPlot1")  ## add the javacode to extract the legend status
    })


  observeEvent(input$Switch, { values$Linked_FP1 <- !values$Linked_FP1    })  ## disable the link in my real app, in this dummy app it switches to plot with different id and colors that is not interactive

  observeEvent(values$NrOfTraces, { 
    values$dYNbs_cyl_el <- rep(T,values$NrOfTraces) ## the list of Yes/No status of groups, from which the 3 buttons on the left are build blue or red
    names(values$dYNbs_cyl_el) <- sapply(1:values$NrOfTraces, function(x) {YNElement(x)}) ## add names to that list
    values$legenditems <- rep(T, values$NrOfTraces)  ## make the legenditem list so that the app doesn't crash when user clicks switchExt without first clicking on legend items
    names(values$legenditems) <- sort(unique(mtcars$cyl)) ## add names to that list

  })


    output$newswitch <- renderUI({ 
    req(input$SelectTrace)
      print(input$SelectTrace)
      if(values$dYNbs_cyl_el[as.numeric(input$SelectTrace)]) { 
    actionButton(inputId = 'SwitchExt', label = icon('refresh'), style = "color: #339fff;   background-color: white;  border-color: #339fff;
                        height: 40px; width: 40px; border-radius: 6px;  border-width: 2px; text-align: center;  line-height: 50%; padding: 0px; display:block; margin: 2px", 
                 onclick = "toggleLegend(this.id);"
                 )}
    else { actionButton(inputId = 'SwitchExt', label = icon('refresh'), style = "color: #f7ad6e;   background-color: white;  border-color: #f7ad6e;
                        height: 40px; width: 40px; border-radius: 6px;  border-width: 2px; text-align: center;  line-height: 50%; padding: 0px; display:block; margin: 2px", 
                   onclick = "toggleLegend(this.id);"
                   )}
    })


  observeEvent(input$tracesPlot1, {
    if(values$Linked_FP1) {
    listTraces <- input$tracesPlot1
    values$legenditems <- listTraces  ## store the list of show/hide for when the plot re-renders here
    listTracesTF <- gsub('legendonly', FALSE, listTraces)
    listTracesTF <- as.logical(listTracesTF)
    lapply(1:values$NrOfTraces, function(el) {
      if(el <= length(listTracesTF)) {
        YNb <- YNElement(el)
        if(values$dYNbs_cyl_el[[YNb]] != listTracesTF[el]) {
          values$dYNbs_cyl_el[[YNb]] <- listTracesTF[el]
        }
      }
    })
    }
  })

  output$YNbuttons <- renderUI({
    req(values$NrOfTraces)
    lapply(1:values$NrOfTraces, function(el) {
      YNb <- YNElement(el)
      if(values$Linked_FP1) {
        if(values$dYNbs_cyl_el[[YNb]] == TRUE) {
        div(actionButton(inputId = YNb, label = icon("check"), 
                         style = "color: #339FFF;   background-color: white;  border-color: #339FFF;height: 34px; width: 34px; border-radius: 6px;  border-width: 2px; text-align: center;  line-height: 50%; padding: 0px; display:block; margin: 2px", 
                         onclick = "toggleLegend(this.id);"))
      } else {
        div(actionButton(inputId = YNb, label = icon("times"), 
                         style = "color: #ff4d4d;   background-color: white;  border-color: #ff4d4d;height: 34px; width: 34px; border-radius: 6px;  border-width: 2px; text-align: center;  line-height: 50%; padding: 0px; display:block; margin: 2px", 
                         onclick = "toggleLegend(this.id);"))
      }
      } 
    })
  }) 


  flipYNb_FP1 <- function(idx){
    YNb <- YNElement(idx)
    values$dYNbs_cyl_el[[YNb]] <- !values$dYNbs_cyl_el[[YNb]]
  }

  observe({
    lapply(1:values$NrOfTraces, function(ob) {
      YNElement <- YNElement(ob)
      observeEvent(input[[YNElement]], {
        if(!values$Linked_FP1) { flipYNb_FP1(ob) }
        }, ignoreInit = T)
    })
  })

}
shinyApp(ui, server)

解法: 在与一些意外行为进行了一些斗争之后,我发现我需要删除 switchExt-plot1 的观察者以阻止按钮翻转两次。

observeEvent(input[['SwitchExt-plot1']], { 
         flipYNb_FP1(as.numeric(input$SelectTrace)) 
      })

正在运行的应用程序是这样的:

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

## js to link buttons to legend
js1 <- c(
  "function toggleLegend(id){",
  "  var ids = id.split('-');",
  "  var plotid = ids[1];",
  "  var index = parseInt(ids[2])-1;", ## correct as the YN buttons are named YesNo-plot1-%d
  "  var plot = document.getElementById(plotid);",
  "  var data = plot.data;",
  "  var v0 = data[index].visible || true;",
  "  var v = v0 == true ? 'legendonly' : true;",
  "  Plotly.restyle(plot, {visible: v}, [index]);",
  "}",
  "function toggleLegend2(id){",
  "  var index = parseInt($('#SelectTrace').val())-1;",
  "  var ids = id.split('-');",
  "  var plotid = ids[1];",
  "  var plot = document.getElementById(plotid);",
  "  var data = plot.data;",
  "  var v0 = data[index].visible || true;",
  "  var v = v0 == true ? 'legendonly' : true;",
  "  Plotly.restyle(plot, {visible: v}, [index]);",
  "}")

## js code to link legend to buttons
js2 <- 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);",
  "  });",
  "}")



YNElement <-    function(idx){sprintf("YesNo-plot1-%d", idx)}


ui <- fluidPage(
  tags$head(
    tags$script(HTML(js1))
  ),
  fluidRow(
    column(2,
           h5("Keep/Drop choices linked to colorscheme 1"),
           uiOutput('YNbuttons')
    ),
    column(8,
           plotlyOutput("plot1")
    ),
    column(2,
           h5('New Button that does not work on legend.', style = 'font-weight:bold'),
           uiOutput('newswitch'),
           br(),
           selectInput(inputId = 'SelectTrace', label = 'Select Trace', choices = 1:3, selected = 1)
           ), style = "margin-top:150px"
  )

)

server <- function(input, output, session) {
  values <- reactiveValues(Linked_FP1 = T, NrOfTraces = length(unique(mtcars$cyl)))

output$plot1 <- renderPlotly({
    if(values$Linked_FP1) {colors <- c('red', 'blue', 'black') } else {colors <- c('black', 'orange', 'gray')}
    p1 <- plot_ly()
    p1 <-  add_trace(p1, data = mtcars, x = ~disp, y = ~mpg, type = 'scatter', mode = 'markers', color = ~as.factor(cyl), colors = colors)
    p1 <- layout(p1, title = 'mtcars group by cyl with switching colors')
    p1 <- plotly_build(p1)

    isolate({ if(values$Linked_FP1) { for(i in seq_along(p1$x$data)){   ## causes the plot to render with previous hide/show selection 
      p1$x$data[[i]]$visible <- values$legenditems[[p1$x$data[[i]]$name]]}  
    } }) ##This block is isolated because otherwise the plot will re-render when the user clicks 1 of the three buttons

    p1 %>% onRender(js2, data = "tracesPlot1")  ## add the javacode to extract the legend status
  })


  observeEvent(values$NrOfTraces, { 
    values$dYNbs_cyl_el <- rep(T,values$NrOfTraces) ## the list of Yes/No status of groups, from which the 3 buttons on the left are build blue or red
    names(values$dYNbs_cyl_el) <- sapply(1:values$NrOfTraces, function(x) {YNElement(x)}) ## add names to that list
    values$legenditems <- rep(T, values$NrOfTraces)  ## make the legenditem list so that the app doesn't crash when user clicks switchExt without first clicking on legend items
    names(values$legenditems) <- sort(unique(mtcars$cyl)) ## add names to that list

  })


  output$newswitch <- renderUI({ 
    req(input$SelectTrace)
    if(values$dYNbs_cyl_el[as.numeric(input$SelectTrace)]) { 
      actionButton(inputId = 'SwitchExt-plot1', label = icon('refresh'), style = "color: #339fff;   background-color: white;  border-color: #339fff;
                   height: 40px; width: 40px; border-radius: 6px;  border-width: 2px; text-align: center;  line-height: 50%; padding: 0px; display:block; margin: 2px", 
                   onclick = "toggleLegend2(this.id)")
    }
    else { actionButton(inputId = 'SwitchExt-plot1', label = icon('refresh'), style = "color: #f7ad6e;   background-color: white;  border-color: #f7ad6e;
                        height: 40px; width: 40px; border-radius: 6px;  border-width: 2px; text-align: center;  line-height: 50%; padding: 0px; display:block; margin: 2px", 
                        onclick = "toggleLegend2(this.id)")}
  })


  observeEvent(input$tracesPlot1, {
    if(values$Linked_FP1) {
      listTraces <- input$tracesPlot1
      values$legenditems <- listTraces  ## store the list of show/hide for when the plot re-renders here
      listTracesTF <- gsub('legendonly', FALSE, listTraces)
      listTracesTF <- as.logical(listTracesTF)
      lapply(1:values$NrOfTraces, function(el) {
        if(el <= length(listTracesTF)) {
          YNb <- YNElement(el)
          if(values$dYNbs_cyl_el[[YNb]] != listTracesTF[el]) {
            values$dYNbs_cyl_el[[YNb]] <- listTracesTF[el]
          }
        }
      })
    }
  })

  output$YNbuttons <- renderUI({
    req(values$NrOfTraces)
    lapply(1:values$NrOfTraces, function(el) {
      YNb <- YNElement(el)
      if(values$Linked_FP1) {
        if(values$dYNbs_cyl_el[[YNb]] == TRUE) {
          div(actionButton(inputId = YNb, label = icon("check"), 
                           style = "color: #339FFF;   background-color: white;  border-color: #339FFF;height: 34px; width: 34px; border-radius: 6px;  border-width: 2px; text-align: center;  line-height: 50%; padding: 0px; display:block; margin: 2px", 
                           onclick = "toggleLegend(this.id);"))
        } else {
          div(actionButton(inputId = YNb, label = icon("times"), 
                           style = "color: #ff4d4d;   background-color: white;  border-color: #ff4d4d;height: 34px; width: 34px; border-radius: 6px;  border-width: 2px; text-align: center;  line-height: 50%; padding: 0px; display:block; margin: 2px", 
                           onclick = "toggleLegend(this.id);"))
        }
      } 
    })
  }) 


  flipYNb_FP1 <- function(idx){
    YNb <- YNElement(idx)
    values$dYNbs_cyl_el[[YNb]] <- !values$dYNbs_cyl_el[[YNb]]
  }

  observe({
    lapply(1:values$NrOfTraces, function(ob) {
      YNElement <- YNElement(ob)
      observeEvent(input[[YNElement]], {
        if(!values$Linked_FP1) { flipYNb_FP1(ob) }
      }, ignoreInit = T)
    })
  })

    }
shinyApp(ui, server)

图片支持评论:

我不确定我是否理解,但让我们从一些事情开始吧。

js1 <- c(
  "function toggleLegend(id){",
  "  var ids = id.split('-');",
  "  var plotid = ids[1];",
  "  var index = parseInt(ids[2])-1;",
  "  var plot = document.getElementById(plotid);",
  "  var data = plot.data;",
  "  var v0 = data[index].visible || true;",
  "  var v = v0 == true ? 'legendonly' : true;",
  "  Plotly.restyle(plot, {visible: v}, [index]);",
  "}",
  "function toggleLegend2(){",
  "  var index = parseInt($('#SelectTrace').val())-1;",
  "  var plot = document.getElementById('plot1');",
  "  var data = plot.data;",
  "  var v0 = data[index].visible || true;",
  "  var v = v0 == true ? 'legendonly' : true;",
  "  Plotly.restyle(plot, {visible: v}, [index]);",
  "}")

actionButton(inputId = 'SwitchExt', ......, onclick = "toggleLegend2()")

是你想要的吗?