Как изменить только размер легенды или только размер маркера с помощью javascript в сюжетном объекте R Shiny

Question

Нет способа напрямую изменить размер маркера легенды в plotly объектах, которые я заметил после тщательного поиска способа сделать это.Я все еще пытаюсь поиграть с этим приложением, но мне может потребоваться целая вечность, чтобы решить требуемое поведение

В конце концов, я нашел способ сделать это с помощью этого кода:

    for(i in seq(1, length(sort(unique(dataframe[[grouping]]) )))) {
      length.group <- nrow(dataframe[which(dataframe[[grouping]]  == sort(unique(dataframe[[grouping]]))[i]), ])
      p$x$data[[i]]$marker$size <- c(rep(markersize,length.group), rep(c(-markersize+2*markerlegendsize), length.group))
    }

в основном это генерирует строку, повторяющую размер n раз, где n - это число точек в trace, которое мы зацикливаем, а затем добавляем равное количество повторов другого размера.Это потому, что маркеры легенды plotly фактически ведут себя как среднее от размера всех маркеров.Мы просто предоставляем двойное количество маркеров, из которых вторая половина намного больше или намного меньше, так что средний размер увеличивается или уменьшается ....

Теперь получается странный эффект помещениятемная граница вокруг legend markers при использовании изменения цвета javascript из ЭТОГО вопроса и ЭТОГО вопроса.

Теперь я хотел бы выяснить, можем ли мы исправить это border color и настроить другое javascript Я получил другой вопрос, чтобы иметь возможность обновить как legend marker size, так и фактический marker size без re-rendering сюжет.

факты о моем приложении: в настоящее время в нем 6 графиков, и все они работают с одной и той же функцией графика.Все размеры легенды numericInputs и все размеры маркеров numericInputs имеют название сюжета в их inputId "markersize_FP1plot", например

Приложение до сих пор

itболее сложный, чем обычный тест app, но это потому, что я хочу убедиться, что нет никакого странного взаимодействия с существующими javascript, прикрепленными к графикам

Первые два непреднамеренных поведения, которые я обнаружил:Маркеры легенды получают темную границу из-за изменения цвета javascript - изменение маркера или размера легенды превращает все следы в серый цвет до повторного нажатия на цвет .... Решение javascript для настройки размера может решить эту проблему как побочный эффект

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

jscolor <- c(
  "function toggleColor0(id){",
  "  var color = document.getElementById(id).value;", # get the color of the colourpicker
  "  var ids = id.split('_');", # split the id
  "  var plotAid = ids[2];", #get the id of plotA (plotw or 3)
  "  var plotBid = ids[3];", #get the id of plotB (plot2 or 4)
  "  var index = parseInt(ids[4]) - 1;", #get the trace number to target
  "  var plotA = document.getElementById(plotAid);", #get the plot element
  "  var dataA = plotA.data;", #access the plot data
  "  var markerA = dataA[index].marker;", #access the plot's markers
  "  markerA.color = color;",  # set the marker color
  "  Plotly.restyle(plotA, {marker: markerA}, [index]);", #restyle plotA
  "  var plotB = document.getElementById(plotBid);", # repeat steps for plot2
  "  var dataB = plotB.data;",
  "  var markerB = dataB[index].marker;",
  "  markerB.color = color;",
  "  Plotly.restyle(plotB, {marker: markerB}, [index]);",
  "};",
  "function toggleColor(id){",
  "  setTimeout(function(){toggleColor0(id);}, 1);",
  "}"
)



colourInput2 <- function(inputId, label, value = "white",
                         showColour = c("both", "text", "background"),
                         palette = c("square", "limited"), allowedCols = NULL,
                         allowTransparent = FALSE, returnName = FALSE,
                         onchange){
  input <- colourpicker::colourInput(inputId, label, value, showColour, palette,
                       allowedCols, allowTransparent, returnName)
  attribs <- c(input$children[[2]]$attribs, onchange = onchange)
  input$children[[2]]$attribs <- attribs
  input
}


ui <- fluidPage(
  tags$head(
    tags$script(HTML(jscolor))  ## to add the javascript to the app
  ),
  fluidRow(
    column(4,plotlyOutput("CleanFP1")),
    column(1, numericInput(inputId = 'markersize_CleanFP1', label = 'marker CleanFP1', min = 1, max = 30, value = 5),
              numericInput(inputId = 'legendsize_CleanFP1', label = 'legend CleanFP1', min = 1, max = 50, value = 22)
    ),
    column(4,plotlyOutput("FP1plot")),
    column(1,
           numericInput(inputId = 'markersize_FP1plot', label = 'marker FP1plot', min = 1, max = 30, value = 3),
           numericInput(inputId = 'legendsize_FP1plot', label = 'legend FP1plot', min = 1, max = 50, value = 10)
    ),
    column(1,uiOutput('buttons_color_1'))
  ),
  fluidRow(
    column(4,plotlyOutput("CleanFP2")),
    column(1, numericInput(inputId = 'markersize_CleanFP2', label = 'marker CleanFP2', min = 1, max = 30, value = 8),
           numericInput(inputId = 'legendsize_CleanFP2', label = 'legend CleanFP2', min = 1, max = 50, value = 22)
    ),
    column(4,plotlyOutput("FP2plot")),
    column(1,
           numericInput(inputId = 'markersize_FP2plot', label = 'marker FP2plot', min = 1, max = 30, value = 11),
           numericInput(inputId = 'legendsize_FP2plot', label = 'legend FP2plot', min = 1, max = 50, value = 10)
    ),
    column(1,uiOutput('buttons_color_2'))
  )
)

server <- function(input, output, session) {
  #functions to make colorinput IDs
  COLElement_FP1 <-    function(idx){sprintf("COL_button_CleanFP1_FP1plot_%d",idx)}
  COLElement_FP2 <-    function(idx){sprintf("COL_button_CleanFP2_FP2plot_%d",idx)}


  TheColors <- c( '#383838', '#011f4b', '#002065', '#005500', '#6d0000', '#c4d000', '#ff5000',  '#433107', 
                  '#505050', '#03396c', '#000cae', '#008800', '#9c0000', '#f0ff00', '#ff6119', '#553e09', 
                  '#737373', '#005b96', '#007aea', '#44aa44', '#d60000', '#fff853', '#ff844c', '#72530c', 
                  '#b2b2b2', '#6497b1', '#a8daf9', '#b5e550', '#ff0000', '#ebecb1', '#ffa77f', '#946c0f',
                  '#d9d9d9', '#b3cde0', '#e4edf2', '#ececa3', '#ff4848', '#f7ffb6', '#ffc4a9', '#c48f14')

  TheColorsSelected <- TheColors[c(12,11,14,29,31,40,19,17,26, 23, 3, 7, 16, 25, 21, 2, 22, 34, 20, 30, 1, 36, 5, 32, 27, 13, 39,4, 38, 18, 8, 35, 9, 15,28, 24, 33, 6, 10, 37)]

  values <- reactiveValues(colorpalette_picked_FP1 = TheColorsSelected, colorpalette_picked_FP2 = TheColorsSelected)



  lapply(c(1:2), function(i) {
    output[[paste('buttons_color_', i,sep = '')]] <- renderUI({
      inputs <- lapply(1:3, function(x) {  ## 3 in my app changes based on clustering output of my model
        Idname <- if(i == 1) { COLElement_FP1(x) } else {COLElement_FP2(x) }
        colour_input <- colourInput2(inputId = Idname, label = NULL,
                                     palette = "limited", allowedCols = TheColors,
                                     value = ifelse(i==1, values$colorpalette_picked_FP1[x], values$colorpalette_picked_FP2[x]),
                                     showColour = "background", returnName = FALSE,
                                     onchange = "toggleColor(this.id)")
        div(colour_input,
            style = "height: 30px; width: 30px; border-radius: 6px;  border-width: 2px; text-align:center; padding: 0px; display:block; margin: 10px"
        )
      })
      do.call(tagList, inputs)
    })
  })

  myplotlyX <- function(THEPLOT, THEDATFRAME, setnr) {
    markersize <- input[[paste('markersize', THEPLOT, sep = '_')]]
    markerlegendsize <- input[[paste('legendsize', THEPLOT, sep = '_')]]
    p <- plot_ly(source = paste('plotlyplot', THEPLOT, sep = '.'))
    p <-  add_trace(p, data = THEDATFRAME, x = THEDATFRAME[['disp']], y = THEDATFRAME[['mpg']], z = THEDATFRAME[['qsec']], type = 'scatter3d', mode = 'markers', color = ~as.factor(THEDATFRAME[['cyl']]), 
                    colors = rep('#797979', 12)) ## just to start with some colors (if there are more traces that Rbrewer palette (n = 8) this sort of plot would crash or give palette errors)
    p <- layout(p, title = 'mtcars group by cyl with switching colors')
    p <- plotly_build(p)
    for(i in seq(1, length(sort(unique(THEDATFRAME$cyl) )))) {
      length.group <- nrow(THEDATFRAME[which(THEDATFRAME[['cyl']]  == sort(unique(THEDATFRAME[['cyl']]))[i]), ])
      p$x$data[[i]]$marker$size <- c(rep(markersize,length.group), rep(c(-markersize+2*markerlegendsize), length.group))
    }
    # p %>% onRender(jslinklegend, data = input[[paste('markersize', THEPLOT, sep = '_')## way to attach the javascript.. not sure if we need to attach one for both sizes, or that it can be done with one script?

    p 
  }

  output$CleanFP1 <- renderPlotly({ myplotlyX('CleanFP1', mtcars, 1) })
  output$FP1plot <- renderPlotly({ myplotlyX('FP1plot', mtcars, 1)})
  output$CleanFP2 <- renderPlotly({ myplotlyX('CleanFP2',mtcars, 2)})
  output$FP2plot <- renderPlotly({ myplotlyX('FP2plot', mtcars, 2)})

}

shinyApp(ui, server)