R Shiny + plotly:使用 javascript 改变轨迹的颜色而不影响多个图中的标记和图例

R Shiny + plotly : change color of a trace with javascript without affecting markers and legend in multiple plots

这是基于 post 的后续问题。

这里的演示应用程序更接近于我真实 shiny app 的更复杂情况,我试图通过替换导致 [=17= 的重新 rendering 的代码来改进] 对象的 javascript 代码改变了现有的 plots

此应用有:
- 4 个独特的地块 ID's
- 一组 2 plots 收听同一组 colourInputs,每个 trace 一组 plot
- 所有 plots 中的 legendmarker size 链接到 numericInputs

针对此解决方案对上一个问题的 javascript 的修改需要:
- 按照 size inputs
- 按照 trace - colourInput 链接
- 目标跟踪 n in 2 plots 基于 colourInput n 属于那些 2 plots

编辑:稍微简化的场景 现在让我们放弃图例问题,因为 Stephane 的解决方案第 2 部分做了我想要的颜色。我稍后会处理图例尺寸。

修改后的版本可能更清晰一些。 javascript 应该:
如果 plot id 是“plot1”或“plot2”听color-set1-1直到-3
如果 plot id 是 'plot3' 或 'plot4',lister 到 color-set2-1 直到 -3

我想我们需要在 js 中添加一些行,例如:“

"var setnr = parseInt(id.split('-')[1]) ;",

查看我们正在查看的是哪一组按钮,然后是一个实现的 if 语句:

 if 'setnr'  == set1 , then var plots =  plot1, plot2
    else if 'setnr == set2, then var plots = plot3, plot4
and then update the trace in 'plots'

在新的应用程序中,color-set1-1、color-set1-2、color-set1-3 仍然针对所有 4 个绘图。

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

js <- c(
  "function(el,x){",
  "  $('[id^=Color]').on('change', function(){",
  "    var color = this.value;",
  "    var id = this.id;",
  "    var index = parseInt(id.split('-')[1]) - 1;",
  "    var data = el.data;",
  "    var marker = data[index].marker;",
  "    marker.color = color;",
  "    Plotly.restyle(el, {marker: marker}, [index]);",
  "  });",
  "}")

ui <- fluidPage(
  fluidRow(
    column(4,plotlyOutput("plot1")),
    column(4,plotlyOutput("plot2")),
    column(4,
    colourInput("Color-1", "Color item 1", value = "blue"),  # these buttons will become named Color-set1-1, Color-set1-2, Color-set1-3
    colourInput("Color-2", "Color item 2", value = "red"),  # but that requires an extra change to the js
    colourInput("Color-3", "Color item 3", value = "green")
  )
    ),
  fluidRow(
    column(4,plotlyOutput("plot3")),
    column(4,plotlyOutput("plot4")),
    column(4,
           colourInput("Color-set2-1", "Color item 1", value = "blue"),
           colourInput("Color-set2-2", "Color item 2", value = "red"),
           colourInput("Color-set2-3", "Color item 3", value = "green")
    )
  )

)

server <- function(input, output, session) {
  values <- reactiveValues(colors1 = c('red', 'blue', 'black'), colors2 = c('yellow', 'blue', 'green')  )

  myplotly <- function(THEPLOT, xvar, setnr) {
    markersize <- input[[paste('markersize', THEPLOT, sep = '_')]] 
    markerlegendsize <- input[[paste('legendsize', THEPLOT, sep = '_')]]
    colors <- isolate ({values[[paste('colors', setnr, sep = '')]]  })
    p <- plot_ly(source = paste('plotlyplot', THEPLOT, sep = '.'))
    p <-  add_trace(p, data = mtcars, x = mtcars[[xvar]], y = ~mpg, type = 'scatter', mode = 'markers', color = ~as.factor(cyl), colors = colors)
    p <- layout(p, title = 'mtcars group by cyl with switching colors')
    p <- plotly_build(p) 
    p  %>% onRender(js)
    } 

  output$plot1 <- renderPlotly({ myplotly('plot1', 'hp', 1) })
  output$plot2 <- renderPlotly({ myplotly('plot2', 'disp', 1)})
  output$plot3 <- renderPlotly({ myplotly('plot3','hp', 2)})
  output$plot4 <- renderPlotly({ myplotly('plot4', 'disp', 2)})

}

shinyApp(ui, server)

原APP:

library(plotly)
library(shiny)
library(htmlwidgets)
library(colourpicker)
library(shinyjs)

## javascript from previous question's answer:
jsCode <- "shinyjs.changelegend = function(){
var paths = d3.select('#plot1').
select('.legend').
select('.scrollbox').
selectAll('.traces').
select('.scatterpts')
.attr('d','M8,0A8,8 0 1,1 0,-8A8,8 0 0,1 8,0Z');}"

ui <- fluidPage(
  tags$script(src = "https://d3js.org/d3.v4.min.js"),
  useShinyjs(),
  extendShinyjs(text = jsCode),
  fluidRow(
    column(2,numericInput(inputId = 'markersize_plot1', label = 'marker', min = 1, max = 40, value = 20)),
    column(2,numericInput(inputId = 'legendsize_plot1', label = 'legend', min = 1, max = 40, value = 10)),
    column(2,numericInput(inputId = 'markersize_plot2', label = 'marker', min = 1, max = 40, value = 4)),
    column(2,numericInput(inputId = 'legendsize_plot2', label = 'legend', min = 1, max = 40, value = 20))
  ),
  fluidRow(
    column(4,plotlyOutput("plot1")),
    column(4,plotlyOutput("plot2")),
    column(2,uiOutput('buttons_color_1'))
  ),
fluidRow(
  column(2,numericInput(inputId = 'markersize_plot3', label = 'marker', min = 1, max = 40, value = 10)),
  column(2,numericInput(inputId = 'legendsize_plot3', label = 'legend', min = 1, max = 40, value = 30)),
  column(2,numericInput(inputId = 'markersize_plot4', label = 'marker', min = 1, max = 40, value = 7)),
  column(2,numericInput(inputId = 'legendsize_plot4', label = 'legend', min = 1, max = 40, value = 40))
),
  fluidRow(
    column(4,plotlyOutput("plot3")),
    column(4,plotlyOutput("plot4")),
    column(2,uiOutput('buttons_color_2'))
    )
)


server <- function(input, output, session) {
  values <- reactiveValues(colors1 = c('red', 'blue', 'black'), colors2 = c('yellow', 'blue', 'green')  )


  lapply(c(1:2), function(i) {
  output[[paste('buttons_color_', i,sep = '')]] <- renderUI({
    isolate({ lapply(1:3, function(x) {  ## 3 in my app changes based on clustering output of my model
      Idname <- if(i == 1) { COLElement_1(x) } else {COLElement_2(x) }
      div(colourpicker::colourInput(inputId = Idname, label = NULL,
                                    palette = "limited", allowedCols = TheColors,
                                    value = values[[paste('colors', i, sep = '')]][x],
                                    showColour = "background", returnName = TRUE),
          style = " height: 30px; width: 30px; border-radius: 6px;  border-width: 2px; text-align:center; padding: 0px; display:block; margin: 10px")
    })
    })})

  outputOptions(output, paste('buttons_color_', i,sep = ''), suspendWhenHidden=FALSE)
  })


  COLElement_1 <-    function(idx){sprintf("COL_button_1-%d",idx)}
  lapply(1:3, function(ob) { 
  COLElement_1 <- COLElement_1(ob)
  observeEvent(input[[COLElement_1]], {
    values[[paste('colors', 1, sep = '')]][ob] <- input[[COLElement_1]]
    plotlyProxy("plot1", session) %>%
      plotlyProxyInvoke("restyle", list(marker = list(color = input[[COLElement_1]])), list(as.numeric(ob)-1))
    plotlyProxy("plot2", session) %>%
      plotlyProxyInvoke("restyle", list(marker = list(color = input[[COLElement_1]])), list(as.numeric(ob)-1))
  })  
  })

  COLElement_2 <-    function(idx){sprintf("COL_button_2-%d",idx)}
  lapply(1:3, function(ob) { 

  COLElement_2 <- COLElement_2(ob)
  observeEvent(input[[COLElement_2]], {
    values[[paste('colors', 2, sep = '')]][ob] <- input[[COLElement_2]]
    plotlyProxy("plot3", session) %>%
      plotlyProxyInvoke("restyle", list(marker = list(color = input[[COLElement_2]])), list(as.numeric(ob)-1))
    plotlyProxy("plot4", session) %>%
      plotlyProxyInvoke("restyle", list(marker = list(color = input[[COLElement_2]])), list(as.numeric(ob)-1))
  })
  })

  myplotly <- function(THEPLOT, xvar, setnr) {
    markersize <- input[[paste('markersize', THEPLOT, sep = '_')]] 
    markerlegendsize <- input[[paste('legendsize', THEPLOT, sep = '_')]]
    colors <- isolate ({values[[paste('colors', setnr, sep = '')]]  })
    p <- plot_ly(source = paste('plotlyplot', THEPLOT, sep = '.'))
    p <-  add_trace(p, data = mtcars, x = mtcars[[xvar]], y = ~mpg, type = 'scatter', mode = 'markers', color = ~as.factor(cyl), colors = colors)
    p <- layout(p, title = 'mtcars group by cyl with switching colors')
    p <- plotly_build(p) 


    # this is a bit of a hack to change the size of the legend markers to not be equal to the plot marker size.
    # it makes a list of 1 size value for each marker in de trace in the plot, and another half of with sizes that are a lot bigger.
    # the legend marker size is effectively the average size of all markers of a trace
    for(i in seq(1, length(sort(unique(mtcars$cyl) )))) {
      length.group <- nrow(mtcars[which(mtcars$cyl  == sort(unique(mtcars$cyl))[i]), ])
      p$x$data[[i]]$marker$size <- c(rep(markersize,length.group), rep(c(-markersize+2*markerlegendsize), length.group))
    }
    p
  } 



output$plot1 <- renderPlotly({ myplotly('plot1', 'hp', 1) })
output$plot2 <- renderPlotly({ myplotly('plot2', 'disp', 1)})
output$plot3 <- renderPlotly({ myplotly('plot3','hp', 2)})
output$plot4 <- renderPlotly({ myplotly('plot4', 'disp', 2)})
}

shinyApp(ui, server)

我迷路了:) 开始吧。这是一个允许更改标记大小的应用程序:

library(plotly)
library(shiny)

js <- paste(c(
  "$(document).ready(function(){",
  "  $('#size').on('change', function(){",
  "    var size = Number(this.value);",
  "    var plot = document.getElementById('plot');",
  "    var data = plot.data;",
  "    $.each(data, function(index,value){",
  "      var marker = data[index].marker;",
  "      marker.size = size;",
  "      Plotly.restyle(plot, {marker: marker}, [index]);",
  "    });",
  "  });",
  "})"), sep = "\n")

ui <- fluidPage(
  tags$head(
    tags$script(HTML(js))
  ),
  plotlyOutput("plot"),
  numericInput("size", "Size", value = 5, min = 1, max = 15)
)

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 
  })

}

shinyApp(ui, server)

这是一个允许更改标记颜色的应用程序:

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

js <- c(
  "function(el,x){",
  "  $('[id^=Color]').on('change', function(){",
  "    var color = this.value;",
  "    var id = this.id;",
  "    var index = parseInt(id.split('-')[1]) - 1;",
  "    var data = el.data;",
  "    var marker = data[index].marker;",
  "    marker.color = color;",
  "    Plotly.restyle(el, {marker: marker}, [index]);",
  "  });",
  "}")

ui <- fluidPage(
  plotlyOutput("plot"),
  colourInput("Color-1", "Color item 1", value = "blue"),
  colourInput("Color-2", "Color item 2", value = "red"),
  colourInput("Color-3", "Color item 3", value = "green")
)

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)
  })

}

shinyApp(ui, server)

有帮助吗?

有了闪亮,就可以使用color=~get(input$XXX)。这是我自己的代码示例:

fig = plot_mapbox()
# POLYGONS
fig = fig %>% add_sf(
  data=districts,
  split=~DISTRICT,
  color=~log10(get(input$multi_indicator_districts.selectors.colorBy)))
# POINTS
fig = fig %>% add_trace(
  type='scatter',
  data=facilities,
  x=~longitude,
  y=~latitude,
  split=~tier)
fig = fig %>% layout(
  mapbox=list(
    zoom=4,
    style='open-street-map'))