0

我的目标是生成一个包含所选颜色代码的文本列表，"#A020F0", "#864BAB", "#4BFF14"例如。我正在使用colourpicker包装中的颜色选择器。我想要的是，每当用户选择一种颜色并按下按钮时，最终选择的颜色的代码都会附加到文本中。

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)

我收到以下错误：cannot coerce type 'closure' to vector of type 'character'

4

2 回答 2

0

您可能想要使用reactiveValuesand 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)

这是一个在 sankey 网络中使用所选颜色的示例。正如我在评论中所说，您将不得不使用paste0or 的sep = ""参数，paste以便组合在一起的元素colorJS不会被空格分隔。这就是为什么我问你粘贴命令的输出是什么。请注意这两个命令及其输出之间的区别...

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"])

这是最小的可重现示例（不需要除您之外没有人可以访问的特殊格式的 Excel 电子表格）...

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)
于 2018-08-03T09:57:48.940 回答
0

这是一个完整的可重现应用程序

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)
于 2018-08-06T15:47:49.617 回答