在努力寻找方法之后,我无法注意到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解决方案可能会解决此问题
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)