How to generate a character of code colors using colors picker

Question

I'm aiming to generate a text list of chosen color codes like "#A020F0", "#864BAB", "#4BFF14" in shiny. I'm using a color picker from the colourpicker package. What I want is that whenever the user selects a color and press the button the code of the ultimate chosen color is appended to the text.

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)

I get the following error: cannot coerce type 'closure' to vector of type 'character'

Why are you having another `renderText` within the `renderText`. And output$t doesn't exist. Delete `renderText`, use `t` instead of `output$t` and make sure t is actually defined by that `paste` line because currently, that `if` clause would prevent in from being defined, causing an error till the button is pressed — OganM, Jul 24 '18 at 00:10
Actually if I delete the inside renderText all color codes will be the same! it updates all the codes however I want to update only the last appended code — Ali Fradi, Jul 24 '18 at 08:49

CJ Yetman · Accepted Answer · 2018-08-14T08:40:07.713

You probably want to use reactiveValues and observeEvent.

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)

Here's an example using the selected colors in a sankey network. As I said in the comments, you're going to have to use paste0 or the sep = "" argument of paste so that the elements combined to make colorJS are not separated by a space. That's why I asked you what the output of your paste command is. Notice the difference between these two commands and their output...

domain <- '"one", "two", "three"'
col_string <- '"#382743", "#916402", "#064713"'

paste('d3.scaleOrdinal().domain([', domain, '])', '.range([', col_string, '])')
# d3.scaleOrdinal().domain([ "one", "two", "three" ]) .range([ "#382743", "#916402", "#064713" ])

paste0('d3.scaleOrdinal().domain([', domain, '])', '.range([', col_string, '])')
# d3.scaleOrdinal().domain(["one", "two", "three"]).range(["#382743", "#916402", "#064713"])

Here's the minimal reproducible example (doesn't require a specifically formatted Excel spreadsheet that no one but you has access to)...

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)

I've marked it, but may I ask you why the result of this as a text can't be accepted in this colorJS <- paste('d3.scaleOrdinal().domain([',input$domaine,'])','.range([',couleurs,'])') while changing colors of a sankey graph.? — Ali Fradi, Aug 03 '18 at 16:17
You might need to use `paste0()` so it doesn’t add a space between each element. — CJ Yetman, Aug 03 '18 at 16:22
the output should be like following: 'blue','#1FF22A','pink','#EFFC00','red' — Ali Fradi, Aug 03 '18 at 17:07
It's about adding that text to colorJS so that the sankey graph gets colored depending on that colors! I don't know what output you're asking about ? — Ali Fradi, Aug 03 '18 at 17:14
When you debug a problem, you compare the output that you get to the output that you want... that helps you determine what the problem is. I know what you want, I don’t know what you are getting. — CJ Yetman, Aug 03 '18 at 17:17
now I got your point, when I integrated your code into my application and I tried to submit the first color it was supposed that the graph is colored with the one already added as text color code, however, the graph didn't get colored it remains blank and darkned as if the app is no longer responding — Ali Fradi, Aug 03 '18 at 18:04
I can't debug your entire program without seeing it. I asked you specifically what the output of your `paste('d3.scaleOrdinal().domain([',input$domaine,'])','.range([',couleurs,'])')` command is, and you haven't told me yet. — CJ Yetman, Aug 06 '18 at 11:28
but you still haven’t told me what the output of your `paste` command is — CJ Yetman, Aug 07 '18 at 07:37
The output should be a text regrouping the colors codes to add it to the sankey argument to color the graph "#A020F0", "#864BAB", "#4BFF14". The text your code is giving isn't working with that sadly and I don't know why — Ali Fradi, Aug 07 '18 at 10:47

score 0 · Answer 2 · answered Aug 06 '18 at 15:47

Here is an entire reproducible app

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)

As I said in the comments above, you need to use `paste0` so that spaces are not added between the elements you are combining to make `colorJS`. See update to my previous answer. — CJ Yetman, Aug 14 '18 at 08:41

How to generate a character of code colors using colors picker

2 Answers2