Allow User to change input selection in selectizeInput

Question

This app is creating a vector of standardised names which I create given some user input (number of channels and replicates). An example of the standard names given the number of channels = 4 and and replicates = 1 is as follows:

c("rep1_C0","rep1_C1","rep1_C2","rep1_C3")

I would like to allow the user to replace the value of the selection with their own custom value. For example to change the input "rep1_C0" to "Control_rep1". And then for it to then update the reactive vector in question. Here is my code:

library(shiny)

ui <- shinyUI(fluidPage(


   sidebarLayout(
      sidebarPanel(
        fluidRow(column(5, numericInput("chans","# Channels",value = 4, min = 1)),
                 column(5, numericInput("reps","# Replicates",value = 1,min = 1))
        ),
        uiOutput("selectnames")
      ),

      mainPanel(
         tableOutput("testcols")
      )
   )
))

server <- shinyServer(function(input, output) {



    standardNames <- reactive({ 
      paste("rep",rep(1:input$reps,each = input$chans),"_",
                           rep(paste("C",0:(input$chans - 1), sep = ""),input$reps),sep = "")
    })

    output$selectnames <- renderUI({
        selectizeInput("selectnames", "Change Names", choices = standardNames(),
                       options = list(maxOptions = input$reps * input$chans))
})

    ## output 

   output$testcols <-  renderTable({
      standardNames()
    })

})

shinyApp(ui = ui, server = server)

Is there some kind of option I can pass in the options sections that will allow this?

Answer 1

With selectizeInput you can set options = list(create = TRUE) to allow the user to add levels to the selection list, but I don't think that is what you want.

Instead, here is code that generates a text input box for each of the standard names, and allows the user to enter a label for them. It uses lapply and sapply to loop over each value and generate/read the inputs.

library(shiny)

ui <- shinyUI(fluidPage(


  sidebarLayout(
    sidebarPanel(
      fluidRow(column(5, numericInput("chans","# Channels",value = 4, min = 1)),
               column(5, numericInput("reps","# Replicates",value = 1,min = 1))
      ),
      uiOutput("setNames")
    ),

    mainPanel(
      tableOutput("testcols")
    )
  )
))

server <- shinyServer(function(input, output) {



  standardNames <- reactive({ 
    paste("rep",rep(1:input$reps,each = input$chans),"_",
          rep(paste("C",0:(input$chans - 1), sep = ""),input$reps),sep = "")
  })

  output$setNames <- renderUI({

    lapply(standardNames(), function(thisName){
      textInput(paste0("stdName_", thisName)
                , thisName
                , thisName)
    })

  })

  labelNames <- reactive({
    sapply(standardNames()
           , function(thisName){
             input[[paste0("stdName_", thisName)]]
           })
  })

  ## output 

  output$testcols <-  renderTable({
    data.frame(
      stdName = standardNames()
      , label = labelNames()
    )
  })

})

shinyApp(ui = ui, server = server)

If you want to hide the list unless the user wants to add labels, you can use a simple checkbox, like this, which hides the label making list until the use checks the box to show it.

library(shiny)

ui <- shinyUI(fluidPage(


  sidebarLayout(
    sidebarPanel(
      fluidRow(column(5, numericInput("chans","# Channels",value = 4, min = 1)),
               column(5, numericInput("reps","# Replicates",value = 1,min = 1))
      )
      , checkboxInput("customNames", "Customize names?")
      , uiOutput("setNames")
    ),

    mainPanel(
      tableOutput("testcols")
    )
  )
))

server <- shinyServer(function(input, output) {



  standardNames <- reactive({ 
    paste("rep",rep(1:input$reps,each = input$chans),"_",
          rep(paste("C",0:(input$chans - 1), sep = ""),input$reps),sep = "")
  })

  output$setNames <- renderUI({

    if(!input$customNames){
      return(NULL)
    }

    lapply(standardNames(), function(thisName){
      textInput(paste0("stdName_", thisName)
                , thisName
                , thisName)
    })

  })

  labelNames <- reactive({

    if(!input$customNames){
      return(standardNames())
    }

    sapply(standardNames()
           , function(thisName){
             input[[paste0("stdName_", thisName)]]
           })
  })

  ## output 

  output$testcols <-  renderTable({
    data.frame(
      stdName = standardNames()
      , label = labelNames()
    )
  })

})

shinyApp(ui = ui, server = server)

Alternatively, if you think the user may want to only change one or a small number of labels, here is a way to allow them to choose which standard name they are applying a label to:

library(shiny)

ui <- shinyUI(fluidPage(


  sidebarLayout(
    sidebarPanel(
      fluidRow(column(5, numericInput("chans","# Channels",value = 4, min = 1)),
               column(5, numericInput("reps","# Replicates",value = 1,min = 1))
      )
      , uiOutput("setNames")
    ),

    mainPanel(
      tableOutput("testcols")
    )
  )
))

server <- shinyServer(function(input, output) {

  vals <- reactiveValues(
    labelNames = character()
  )


  standardNames <- reactive({ 
    out <- paste("rep",rep(1:input$reps,each = input$chans),"_",
                 rep(paste("C",0:(input$chans - 1), sep = ""),input$reps),sep = "")
    vals$labelNames = setNames(out, out)

    return(out)
  })

  output$setNames <- renderUI({

    list(
      h4("Add labels")
      , selectInput("nameToChange", "Standard name to label"
                    , names(vals$labelNames))
      , textInput("labelToAdd", "Label to apply")
      , actionButton("makeLabel", "Set label")
    )

  })

  observeEvent(input$makeLabel, {
    vals$labelNames[input$nameToChange] <- input$labelToAdd
  })

  ## output 

  output$testcols <-  renderTable({
    data.frame(
      stdName = standardNames()
      , label = vals$labelNames
    )
  })

})

shinyApp(ui = ui, server = server)