本文介绍了当服务器中建立colourInput时,R Shiny用javascript绘图地更新痕迹颜色的处理方法,对大家解决问题具有一定的参考价值,需要的朋友们下面随着小编来一起学习吧!

问题描述

这是对上一个问题

在此应用程序(更好地反映了我的真实应用程序)中,发生了以下情况:

In this app (which reflects my real app better) the following situation happens:

我有两组地块,
-一组的2个图显示相同的迹线,只是绘制了不同的列
-每个图都在我的应用程序中的不同页面上
-这两个图应链接到1组colourInputs,在第2页上
-colourInputsrenderUI * 1

I have 2 sets of plots,
- the 2 plots of a set show the same traces, just different columns plotted
- each plot is on a different page in my app
- The two plots should be linked to 1 set of colourInputs, on page 2
- The colourInputs are built in the server with renderUI *1

* 1:由于这个原因,我相信p %>% onRender(js)方法将无法正常工作,正如我先前在问题

*1: for this reason, I believe that p %>% onRender(js) approach will not work as I saw earlier in THIS question for the YNbuttons there

目标:如果colourInput 'COL_button_plot1_plot2_N'更改->更改plot1plot2

Goal: if colourInput 'COL_button_plot1_plot2_N' changes -> change the color of trace N-1 (*2) in plot1 AND plot2

* 2:跟踪号用于0-n,,因此是colourinput nr -1

*2: trace numbers run for 0-n, thus colourinput nr -1

我更改了colorInputs的命名代码,以包含它们应针对的两个图的名称:

I altered the naming code for the colorInputs to contain the names of both plots they should target:

COLElement_1 <-    function(idx){sprintf("COL_button_plot1_plot2_%d",idx)}

我怀疑由于colourInputsrenderUI() uiOutput()

到目前为止,我已经尝试过尝试一种JavaScript,该JavaScript可以获取2个地块ID和数据并具有重设样式功能,但是我仍在坚持如何使其按应用程序预期的那样工作.至少可能有助于将想法传播出去.

So far I designed an attempt at a javascript that grabs the 2 plot IDs and data and has the restyle function in it, but I'm stuck on how to get it to work as intended in the app. It might at least help to get the idea across.

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.

UPDATED APP:Got the working solution thanks to the answer, but when I start changing the plot names it breaks. Here I changed all references of 'plot1' to 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不返回颜色选择器的值.

There are some typos in your JS code, and this.value does not return the value of the colour picker.

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属性:

Now let's modify colourInput, allowing a onchange attribute:

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)
  })

这篇关于当服务器中建立colourInput时,R Shiny用javascript绘图地更新痕迹颜色的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持!

09-27 16:48