Question

这是一个基于THIS帖子的后续问题。

此处的演示应用更贴近了我实际的shiny app的更复杂情况，我试图通过替换导致rendering对象重新plotly的代码来改善通过javascript代码来更改现有的plots。

此应用具有：
-4个具有唯一ID's
的地块 -2组plots收听同一组colourInputs，每个trace中每个plot收听1个
-所有legend中的marker和size plots都链接到numericInputs

对此解决方案的上一个问题对javascript进行的修改需要：
-按照size inputs
-按照trace-colourInput链接
-基于属于这两个n的{{1}} plots的2 colourInput中的目标跟踪n。

编辑：稍微简化的场景 现在放下图例问题，因为Stephane的解决方案第2部分做了我想要的颜色。稍后将处理图例大小。

修改后的版本可能会更清晰一些。 plots应该：
如果剧情ID是“ javascript”或“ plot1”，请听plot2直到color-set1-1
如果情节ID是'-3'或'plot3'，则列出列表到plot4直到color-set2-1

我想我们需要在-3中添加一些行，例如：“

js

看看我们正在查看哪组按钮，然后是一个if语句，它实现了：

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

在新应用中，颜色设置1-1，颜色设置1-2，颜色设置1-3仍以所有4个图为目标。

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

原始APP：

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)

Answer 1

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

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)

有帮助吗？

Answer 2

使用闪亮，您可以使用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'))

R Shiny + plotly：使用javascript更改迹线的颜色，而不会影响多个图中的标记和图例

2 个答案: