Shiny 如何使用颜色选择器生成代码颜色的字符

我的目标是生成所选颜色代码的文本列表，如中的

“#A020F0”、“#864BAB”、“#4BFF14”

。我正在使用

颜色选择器

软件包中的颜色选择器。我想要的是，每当用户选择一种颜色并按下按钮时，最终选择的颜色的代码就会附加到文本中

library(shiny)
library(colourpicker)
library(devtools)
ui <- fluidPage( colourInput("col", "Select colour", "purple"),
                 numericInput(inputId='x', label="colors", value=3, min=1, step=1)
                ,actionButton(inputId='OK', label="enter color"),
                textOutput("couleurs"))



    server <- function(input, output) {
      output$couleurs<-renderText({
        v='"'
        t=''
        for (k in c(1:input$x)) {
          if(input$OK){
            t=input$col
          }
          v=paste(v,t,',"')
        }
        return(v)
      })



    }

    shinyApp(ui = ui, server = server)

库（闪亮）
图书馆（色彩采集器）
图书馆（devtools）
ui您可能希望使用
反应值
和
观察事件

library(shiny)
library(colourpicker)

ui <- fluidPage(
        colourInput('col', 'Select colour', 'purple'),
        actionButton(inputId = 'OK', label = 'enter color'),
        textOutput('couleurs')
      )

server <- function(input, output) {
  values <- reactiveValues(col_string = '')

  observeEvent(input$OK, {
    if (values$col_string == '') {
      values$col_string <- paste0('"', input$col, '"')
    } else {
      values$col_string <- paste0(values$col_string, ', ', paste0('"', input$col, '"'))
    }
  })

  output$couleurs <- renderText({ values$col_string })
}

shinyApp(ui = ui, server = server)

这里是一个最小的可复制示例（不需要专门格式化的Excel电子表格，只有您可以访问该电子表格）

库（闪亮）
图书馆（色彩采集器）
图书馆（网络3）
ui这是一个完整的可复制应用程序

library(shiny)
library(networkD3)
library(openxlsx)
library(colourpicker)
library(devtools)
library(readr)


ui <- fluidPage( 

  tabsetPanel(
  tabPanel("Data",  fileInput("myData", "Upload your data "),
           helpText(h6("Default max. file size is 5MB")),
           uiOutput("tb")),
  tabPanel("Display graph", flowLayout(

           flowLayout( verticalLayout(sliderInput(inputId ='x',label = "Font size",min = 8,max = 24,value = 11,step = 1),
                                      sliderInput(inputId ='y',label = "Graph size",min = 12,max = 20,value = 20,step = 2)
           ),verticalLayout(textOutput("codec"),
           colourInput("col", "Select colour", "purple"),
           actionButton(inputId = 'OK', label = 'enter color'))
           ),



           verticalLayout(textInput("domaine","Group names "),
                          textInput("couleur","Group colors","'blue','#1FF22A','pink','#EFFC00','red'"),
                          helpText("* Same order of group names as",'"1600D9","red"#F7F705"')
           ),
            uiOutput("sankey",position="right"))),
  tabPanel("Summary",  uiOutput("s")))


)
server <- function(input, output) {






  #read links data 
  data <- reactive({
    file1 <- input$myData
    if (is.null(file1)) {
      return(NULL)
    }
    read.xlsx(file1$datapath,startRow = 2,sheet = 1,colNames = TRUE,cols =1:6)

  })


  #about data
  output$filedf <- renderTable({
    if (is.null(data())) {
      return ()
    }
    input$myData
  })

  output$s <- renderUI({
    if (is.null(data()))
      h1("Check your file!", align='center'
      )
    else
      tabsetPanel(
        tabPanel("Source", tableOutput("from")),
        tabPanel("Target", tableOutput("to")),
        tabPanel("Value", tableOutput("weight"))

      )
  }) 

  #summary data 
  output$from <- renderTable({
    if (is.null(data())) {
      return ()
    }
    x <- reactive({
      file1 <- input$myData
      if (is.null(file1)) {
        return(NULL)
      }
      read.xlsx(file1$datapath,startRow = 2,sheet = 1,colNames = TRUE,cols =2)

    })


    summary(x())
  })

  output$to <- renderTable({
    if (is.null(data())) {
      return ()
    }
    x <- reactive({
      file1 <- input$myData
      if (is.null(file1)) {
        return(NULL)
      }
      read.xlsx(file1$datapath,startRow = 2,sheet = 1,colNames = TRUE,cols =4)

    })


    summary(x())
  })

  output$weight <- renderTable({
    if (is.null(data())) {
      return ()
    }
    x <- reactive({
      file1 <- input$myData
      if (is.null(file1)) {
        return(NULL)
      }
      read.xlsx(file1$datapath,startRow = 2,sheet = 1,colNames = TRUE,cols =5)

    })


    summary(x())
  })
  #display data table 
  output$table <- renderTable({
    if (is.null(data())) {
      return ()
    }
    data()
  })




  #read nodes data
  label <- reactive({
    file1 <- input$myData
    if (is.null(file1)) {
      return(NULL)
    }
    read.xlsx(file1$datapath,startRow = 2,sheet = 1,colNames = TRUE,cols = 7:8)
  })

  values <- reactiveValues(col_string = '')

  observeEvent(input$OK, {
    if (values$col_string == '') {
      values$col_string <- paste0('"', input$col, '"')
    } else {
      values$col_string <- paste0(values$col_string, ', ', paste0('"', input$col, '"'))
    }
  })

  output$couleurs <- renderText({ values$col_string })
  output$splot <- renderSankeyNetwork({




    colorJS <- paste('d3.scaleOrdinal().domain([',input$domaine,'])','.range([',couleurs,'])')

    sankeyNetwork(
      Links = data(),
      Nodes = label(),
      Source = 'i',
      Target = 'j',
      Value = 'value',
      NodeID = "name",
      fontSize = input$x,
      nodeWidth =0.6*input$x,
      NodeGroup = "ngroup", LinkGroup = "lgroup"
      ,colourScale = colorJS
    )
  })



  #render demanded outputs
  output$tb <- renderUI({
    if (is.null(data()))
      h3("Watch me - Tutorial",br(),tags$video(src='Sankey.mp4',type="video/mp4",width="720px",height="450px",controls="controls"),align="center")
    else
      tabsetPanel(
        tabPanel("About file", tableOutput("filedf")),
        tabPanel("Data",tableOutput("table"))

      )
  })






  output$codec<-renderText({paste("Code:",input$col)})

  output$sankey <- renderUI({
    if (is.null(data()))
      h1("Check your file!", align='center'
      )
    else
      sankeyNetworkOutput("splot",width = 46*input$y,height = 23*input$y)
  })




}

shinyApp(ui = ui, server = server)

库（闪亮）
图书馆（网络3）
库（openxlsx）
图书馆（色彩采集器）
图书馆（devtools）
图书馆（readr）
ui为什么在
renderText
中有另一个
renderText
。输出$t不存在。删除
renderText
，使用
t
而不是
output$t
，并确保t实际上是由
paste
行定义的，因为当前，
if
子句会阻止in被定义，导致错误，直到按下按钮为止。如果我删除内部渲染文本，则所有颜色代码都将相同！它更新了所有的代码，但是我只想更新最后附加的代码非常感谢这正是我需要的我已经标记了它，但是我可以问你为什么在这个颜色中不能接受文本的结果。你可能需要使用
paste0（）
因此它不会在每个元素之间添加空格。输出应该如下所示：“蓝色”、“粉色”、“EFFC00”、“红色”，但输出是什么？正如我在上面的评论中所说，您需要使用
paste0
，这样就不会在要组合的元素之间添加空格，以生成
colorJS
。请参阅我先前答案的更新。
library(shiny)
library(colourpicker)
library(networkD3)

ui <- fluidPage(
  colourInput('col', 'Select colour', 'purple'),
  actionButton(inputId = 'OK', label = 'enter color'),
  textOutput('couleurs'),
  actionButton(inputId = 'plot', label = 'plot'),
  sankeyNetworkOutput("splot")
)

server <- function(input, output) {
  values <- reactiveValues(col_string = '')

  observeEvent(input$OK, {
    if (values$col_string == '') {
      values$col_string <- paste0('"', input$col, '"')
    } else {
      values$col_string <- paste0(values$col_string, ', ', paste0('"', input$col, '"'))
    }
  })

  output$couleurs <- renderText({ values$col_string })

  observeEvent(input$plot, {
    if (values$col_string != '') {
      output$splot <- renderSankeyNetwork({
        data <- data.frame(i = c(0, 0, 0),
                           j = c(1, 2, 3),
                           value = c(3, 1, 2),
                           lgroup = c("lgroup1", "lgroup2", "lgroup2"))

        label <- data.frame(name = c("zero", "one", "two", "three"),
                            ngroup = c("ngroup1", "ngroup2", "ngroup2", "ngroup2"))

        domain <- paste0("'", paste(unique(c(as.character(data$lgroup), as.character(label$ngroup))), collapse = "', '"), "'")

        colorJS <-
          paste0('d3.scaleOrdinal().domain([', domain, ']).range([', values$col_string, '])')

        sankeyNetwork(Links = data, Nodes = label, Source = 'i', Target = 'j',
                      Value = 'value', NodeID = "name", NodeGroup = "ngroup",
                      LinkGroup = "lgroup", colourScale = colorJS)
      })
    }
  })
}

shinyApp(ui = ui, server = server)

library(shiny)
library(networkD3)
library(openxlsx)
library(colourpicker)
library(devtools)
library(readr)


ui <- fluidPage( 

  tabsetPanel(
  tabPanel("Data",  fileInput("myData", "Upload your data "),
           helpText(h6("Default max. file size is 5MB")),
           uiOutput("tb")),
  tabPanel("Display graph", flowLayout(

           flowLayout( verticalLayout(sliderInput(inputId ='x',label = "Font size",min = 8,max = 24,value = 11,step = 1),
                                      sliderInput(inputId ='y',label = "Graph size",min = 12,max = 20,value = 20,step = 2)
           ),verticalLayout(textOutput("codec"),
           colourInput("col", "Select colour", "purple"),
           actionButton(inputId = 'OK', label = 'enter color'))
           ),



           verticalLayout(textInput("domaine","Group names "),
                          textInput("couleur","Group colors","'blue','#1FF22A','pink','#EFFC00','red'"),
                          helpText("* Same order of group names as",'"1600D9","red"#F7F705"')
           ),
            uiOutput("sankey",position="right"))),
  tabPanel("Summary",  uiOutput("s")))


)
server <- function(input, output) {






  #read links data 
  data <- reactive({
    file1 <- input$myData
    if (is.null(file1)) {
      return(NULL)
    }
    read.xlsx(file1$datapath,startRow = 2,sheet = 1,colNames = TRUE,cols =1:6)

  })


  #about data
  output$filedf <- renderTable({
    if (is.null(data())) {
      return ()
    }
    input$myData
  })

  output$s <- renderUI({
    if (is.null(data()))
      h1("Check your file!", align='center'
      )
    else
      tabsetPanel(
        tabPanel("Source", tableOutput("from")),
        tabPanel("Target", tableOutput("to")),
        tabPanel("Value", tableOutput("weight"))

      )
  }) 

  #summary data 
  output$from <- renderTable({
    if (is.null(data())) {
      return ()
    }
    x <- reactive({
      file1 <- input$myData
      if (is.null(file1)) {
        return(NULL)
      }
      read.xlsx(file1$datapath,startRow = 2,sheet = 1,colNames = TRUE,cols =2)

    })


    summary(x())
  })

  output$to <- renderTable({
    if (is.null(data())) {
      return ()
    }
    x <- reactive({
      file1 <- input$myData
      if (is.null(file1)) {
        return(NULL)
      }
      read.xlsx(file1$datapath,startRow = 2,sheet = 1,colNames = TRUE,cols =4)

    })


    summary(x())
  })

  output$weight <- renderTable({
    if (is.null(data())) {
      return ()
    }
    x <- reactive({
      file1 <- input$myData
      if (is.null(file1)) {
        return(NULL)
      }
      read.xlsx(file1$datapath,startRow = 2,sheet = 1,colNames = TRUE,cols =5)

    })


    summary(x())
  })
  #display data table 
  output$table <- renderTable({
    if (is.null(data())) {
      return ()
    }
    data()
  })




  #read nodes data
  label <- reactive({
    file1 <- input$myData
    if (is.null(file1)) {
      return(NULL)
    }
    read.xlsx(file1$datapath,startRow = 2,sheet = 1,colNames = TRUE,cols = 7:8)
  })

  values <- reactiveValues(col_string = '')

  observeEvent(input$OK, {
    if (values$col_string == '') {
      values$col_string <- paste0('"', input$col, '"')
    } else {
      values$col_string <- paste0(values$col_string, ', ', paste0('"', input$col, '"'))
    }
  })

  output$couleurs <- renderText({ values$col_string })
  output$splot <- renderSankeyNetwork({




    colorJS <- paste('d3.scaleOrdinal().domain([',input$domaine,'])','.range([',couleurs,'])')

    sankeyNetwork(
      Links = data(),
      Nodes = label(),
      Source = 'i',
      Target = 'j',
      Value = 'value',
      NodeID = "name",
      fontSize = input$x,
      nodeWidth =0.6*input$x,
      NodeGroup = "ngroup", LinkGroup = "lgroup"
      ,colourScale = colorJS
    )
  })



  #render demanded outputs
  output$tb <- renderUI({
    if (is.null(data()))
      h3("Watch me - Tutorial",br(),tags$video(src='Sankey.mp4',type="video/mp4",width="720px",height="450px",controls="controls"),align="center")
    else
      tabsetPanel(
        tabPanel("About file", tableOutput("filedf")),
        tabPanel("Data",tableOutput("table"))

      )
  })






  output$codec<-renderText({paste("Code:",input$col)})

  output$sankey <- renderUI({
    if (is.null(data()))
      h1("Check your file!", align='center'
      )
    else
      sankeyNetworkOutput("splot",width = 46*input$y,height = 23*input$y)
  })




}

shinyApp(ui = ui, server = server)