如何在R Shiny绘图对象中仅使用JavaScript更改图例大小或标记大小

时间：2019-03-14 20:01:59

标签： javascript r shiny plotly r-plotly

在努力寻找方法之后，我无法注意到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中的点数，然后在a中添加相等数量的重复项不同的大小。这是因为plotly的图例标记实际上是所有标记大小的平均值。我们只提供了两倍的标记，第二个标记的后半部分更大或更小，因此平均大小会增加或减小。...

现在，这会产生一种奇怪的效果，即在使用THIS问题和{更改颜色的legend markers时，在javascript周围放置深色的 border {3}}问题。

我现在想发现的是，我们是否可以修复border color，并调整另一个问题中得到的另一个javascript，以便能够同时更新legend marker size和实际的marker size而没有re-rendering的情节。

我的应用事实： 当前有6个地块，所有地块都在同一个地块函数上运行。 例如，所有图例大小numericInputs和所有标记大小numericInputs在其inputId“ markersize_FP1plot”中都具有绘图名称

到目前为止的应用

它比通常的测试app更复杂，但这是因为我要确保与附着在地块上的现有javascript之间没有奇怪的交互作用

我发现的前两个意外行为是： -图例标记由于颜色变化而导致黑色边框 -更改标记或图例的大小会使所有迹线变成灰色，直到再次单击颜色为止。...大小设置的javascript解决方案可能会解决此问题

THIS 

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)

0 个答案:

没有答案
相关问题
最新问题