当在服务器中构建 colourInput 时，R Shiny 用 javascript 绘图更新跟踪颜色
R Shiny plotly update trace colors with javascript when colourInput is build in the server
这是对上一个问题的修改版本
在这个应用程序（更好地反映了我的真实应用程序）中发生了以下情况：
我有2套地块，
- 一组的 2 个图显示相同的轨迹，只是绘制了不同的列
- 每个图都在我的应用程序的不同页面上
- 这两个地块应链接到第 2 页
的一组 colourInputs
- colourInputs 内置于服务器 renderUI *1
*1：出于这个原因，我认为 p %>% onRender(js) 方法不会像我之前在 问题 YNbuttons 中看到的那样行得通
目标：
如果 colourInput 'COL_button_plot1_plot2_N' 更改 -> 在 plot1 AND plot2[= 中更改 trace N-1 (*2) 的 color 38=]
*2：0-n, 的追踪数 运行 因此 colourinput nr -1
我更改了 colorInputs 的命名代码以包含它们应该定位的两个图的名称：
COLElement_1 <- function(idx){sprintf("COL_button_plot1_plot2_%d",idx)}
我怀疑我们需要在 colourInput 上附加 onclick = "toggleColor(this.id)") 而不是 plot 上的 onRender() 因为 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 没有 return 颜色选择器的值。
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)
})
这是对上一个问题的修改版本
在这个应用程序（更好地反映了我的真实应用程序）中发生了以下情况：
我有2套地块，
- 一组的 2 个图显示相同的轨迹，只是绘制了不同的列
- 每个图都在我的应用程序的不同页面上
- 这两个地块应链接到第 2 页
的一组 colourInputs
- colourInputs 内置于服务器 renderUI *1
*1：出于这个原因，我认为 p %>% onRender(js) 方法不会像我之前在 YNbuttons 中看到的那样行得通
目标：
如果 colourInput 'COL_button_plot1_plot2_N' 更改 -> 在 plot1 AND plot2[= 中更改 trace N-1 (*2) 的 color 38=]
*2：0-n, 的追踪数 运行 因此 colourinput nr -1
我更改了 colorInputs 的命名代码以包含它们应该定位的两个图的名称：
COLElement_1 <- function(idx){sprintf("COL_button_plot1_plot2_%d",idx)}
我怀疑我们需要在 colourInput 上附加 onclick = "toggleColor(this.id)") 而不是 plot 上的 onRender() 因为 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 没有 return 颜色选择器的值。
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)
})