[英]R Shiny plotly update trace colors with javascript when colourInput is build in the server
这是一个修改版本对前一个问题在这里
在此应用程序（更好地反映了我的真实应用程序）中，发生以下情况：
我有两套地块
-一组的2个图显示相同的迹线，仅绘制不同的列
-每个情节都在我应用程序的不同页面上
-这两个图应链接到第2页上的一组colourInputs
colourInputs是使用renderUI * 1构建在服务器中的
* 1：由于这个原因，我相信p %>% onRender(js)方法将无法正常工作，正如我之前在此问题中针对YNbuttons看到的那样
目标：如果colourInput 'COL_button_plot1_plot2_N'的变化- >改变color的trace N-1 （2 *）在plot1 AND plot2
* 2：迹线编号为0-n,因此colourinput nr -1
我更改了colorInputs的命名代码，以包含它们应针对的两个图的名称：
COLElement_1 <- function(idx){sprintf("COL_button_plot1_plot2_%d",idx)}
我怀疑，我们需要onclick = "toggleColor(this.id)")附着在colourInput而非onRender()的plot ，由于renderUI() uiOutput()中的colourInputs
到目前为止，我已经尝试过尝试一种Javascript，它可以获取2个图ID和数据并具有重设样式功能，但是我仍在坚持如何使其按应用程序预期的那样工作。 至少可以帮助传播这个想法。
jscolor <- c(
"function toggleColor(id){",
" var color = this.value;", # get the color of the colourpicker
" var ids = id.split('_');", # split the ids
" var plotAid = ids[2];", #get the id of plotA (plot1 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(plot1id);", #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]);",
" });"
)
测试应用程序：
library(plotly)
library(shiny)
library(colourpicker)
library(htmlwidgets)
# jscolor <- c(......)
ui <- fluidPage(
tags$head(
tags$script(HTML(jscolor)) ## to add the javascript to the app
),
fluidRow(
column(4,plotlyOutput("plot1")),
column(4,plotlyOutput("plot2")),
column(4,uiOutput('buttons_color_1')
)
),
fluidRow(
column(4,plotlyOutput("plot3")),
column(4,plotlyOutput("plot4")),
column(4,uiOutput('buttons_color_2'))
)
)
server <- function(input, output, session) {
#functions to make colorinput IDs
COLElement_1 <- function(idx){sprintf("COL_button_plot1_plot2_%d",idx)}
COLElement_2 <- function(idx){sprintf("COL_button_plot3_plot4_%d",idx)}
TheColors <- c('#383838', '#5b195b','#1A237E', '#000080', '#224D17', '#cccc00', '#b37400', '#990000',
'#505050', '#a02ca0', '#000099', '#2645e0', '#099441', '#e5e500', '#cc8400', '#cc0000',
'#737373', '#e53fe5', '#0000FF', '#4479e1', '#60A830', '#ffff00','#e69500', '#ff0000',
'#b2b2b2', '#eb6ceb', '#6666ff', '#d0a3ff', '#9FDA40', '#ffff7f', '#ffa500', '#ff4c4c',
'#d9d9d9', '#f198f1', '#C5CAE9','#BBDEFB','#D9DF1D', '#ffffcc','#ffc04d', '#ff9999')
values <- reactiveValues(colors1 = TheColors, colors2 = sort(TheColors))
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",
onclick = "toggleColor(this.id)")
})
})})
outputOptions(output, paste('buttons_color_', i,sep = ''), suspendWhenHidden=FALSE)
})
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
}
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)
更新的应用程序：有了答案，得到了可行的解决方案，但是当我开始更改绘图名称时，它就会中断。 在这里，我将“ plot1”的所有引用都更改为plotx。
library(plotly)
library(shiny)
library(colourpicker)
library(htmlwidgets)
jscolor <- c(
"function toggleColor(id){",
" var color = document.getElementById(id).value;", # get the color of the colourpicker
" var ids = id.split('_');", # split the ids
" var plotAid = ids[2];", #get the id of plotA (plotx 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]);",
"};"
)
colourInput2 <- function(inputId, label, value = "white",
showColour = c("both", "text", "background"),
palette = c("square", "limited"), allowedCols = NULL,
allowTransparent = FALSE, returnName = FALSE,
onchange){
input <- 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("plotx")),
column(4,plotlyOutput("plot2")),
column(4,uiOutput('buttons_color_1')
)
),
fluidRow(
column(4,plotlyOutput("plot3")),
column(4,plotlyOutput("plot4")),
column(4,uiOutput('buttons_color_2'))
)
)
server <- function(input, output, session) {
#functions to make colorinput IDs
COLElement_1 <- function(idx){sprintf("COL_button_plotx_plot2_%d",idx)}
COLElement_2 <- function(idx){sprintf("COL_button_plot3_plot4_%d",idx)}
TheColors <- c('#383838', '#5b195b','#1A237E', '#000080', '#224D17', '#cccc00', '#b37400', '#990000',
'#505050', '#a02ca0', '#000099', '#2645e0', '#099441', '#e5e500', '#cc8400', '#cc0000',
'#737373', '#e53fe5', '#0000FF', '#4479e1', '#60A830', '#ffff00','#e69500', '#ff0000',
'#b2b2b2', '#eb6ceb', '#6666ff', '#d0a3ff', '#9FDA40', '#ffff7f', '#ffa500', '#ff4c4c',
'#d9d9d9', '#f198f1', '#C5CAE9','#BBDEFB','#D9DF1D', '#ffffcc','#ffc04d', '#ff9999')
values <- reactiveValues(colors1 = TheColors, colors2 = sort(TheColors))
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_1(x) } else {COLElement_2(x) }
colour_input <- colourInput2(inputId = Idname, label = NULL,
palette = "limited", allowedCols = TheColors,
value = isolate(values[[paste('colors', i, sep = '')]][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)
})
# useless: outputOptions(output, paste('buttons_color_', i,sep = ''), suspendWhenHidden=FALSE)
})
myplotly <- function(THEPLOT, xvar, setnr) {
markersize <- 2
markerlegendsize <- 10
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
}
output$plotx <- renderPlotly({ myplotly('plotx', '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)
JS代码中有一些错别字，而this.value不会返回颜色选择器的值。
jscolor <- c(
"function toggleColor(id){",
" var color = document.getElementById(id).value;", # get the color of the colourpicker
" var ids = id.split('_');", # split the ids
" var plotAid = ids[2];", #get the id of plotA (plot1 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]);",
"};"
)
现在，让我们修改colourInput ，允许使用onchange属性：
colourInput2 <- function(inputId, label, value = "white",
showColour = c("both", "text", "background"),
palette = c("square", "limited"), allowedCols = NULL,
allowTransparent = FALSE, returnName = FALSE,
onchange){
input <- colourInput(inputId, label, value, showColour, palette,
allowedCols, allowTransparent, returnName)
attribs <- c(input$children[[2]]$attribs, onchange = onchange)
input$children[[2]]$attribs <- attribs
input
}
在server.R ：
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_1(x) } else {COLElement_2(x) }
colour_input <- colourInput2(inputId = Idname, label = NULL,
palette = "limited", allowedCols = TheColors,
value = isolate(values[[paste('colors', i, sep = '')]][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)
})
# useless: outputOptions(output, paste('buttons_color_', i,sep = ''), suspendWhenHidden=FALSE)
})
如何通过R Shining中的JavaScript通过通用按钮+ selectInput更改迹线n的图例状态
[英]How to change plotly legendstatus of trace n with a generic button + selectInput through javascript in R shiny
R Shiny + plotly：使用 javascript 更改轨迹颜色而不影响多个图中的标记和图例
[英]R Shiny + plotly : change color of a trace with javascript without affecting markers and legend in multiple plots
使用javascript时从闪亮的应用程序中进行绘图绘制时出错
[英]Error in plotly graph download from a shiny app when using javascript
如何在不重新渲染的情况下响应动作按钮更新R Shiny中的绘图小部件的显示/隐藏痕迹
[英]How to update show/hide traces of a plotly widget in R shiny in response to actionbuttons without re-rendering
在绘制数据被更改时，在R中绘制更新而不重新创建小部件
[英]Update plotly in R without recreating widget when plotted data is altered
将R Shiny Code发送到Javascript时，它会多次执行
[英]R Shiny Code gets executed multiple times when sending it to Javascript
声明:本站的技术帖子网页，遵循CC BY-SA 4.0协议，如果您需要转载，请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.