当在服务器中构建colourInput时,R Shiny使用javascript逐步更新跟踪颜色

问题描述 投票:0回答:1

这是前一个问题here的修改版本

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

我有2套情节, - 一组的2个图显示相同的迹线,只绘制不同的列 - 每个情节都在我的应用程序的不同页面上 - 这两个图应该链接到第1页上的一组colourInputs - 使用colourInputs * 1在服务器中构建renderUI

* 1:因此,我相信p %>% onRender(js)方法不会像我之前在THIS问题中看到的YNbuttons那样有效

目标:如果colourInput 'COL_button_plot1_plot2_N'改变 - >在colortrace改变N-1 plot1(* 2)的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和数据,并在其中具有restyle功能,但我坚持如何让它在应用程序中按预期工作。这可能至少有助于实现这个想法。

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]);",
  "  });"
)

测试APP:

   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)
javascript r shiny plotly r-plotly
1个回答
1
投票

您的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)
  })
© www.soinside.com 2019 - 2024. All rights reserved.