vendredi 15 février 2019

Combine multiple checkboxInput and checkboxgroupinput selections in a named list

I'm building a section for my app and I'm struggling to create the desired output.

I have: n checkboxInputs for my 'channels' then i checkboxGroupInputs of parameters for each channel (identical sets) and j checkboxGroupInputs of calculations to select for each ChannelxParameter combination.

I deliberately didn't go overboard, so I chose not to allow the user to choose different statistics per Channel * Parameter combination.

What I am looking to get as reactive output is a named list :
1. where names are combined names of input of the Channels and Parameters: i.e. paste('Channel', 'Parameter')
2. "values" are text strings of the selected statistics / calculations
3. The list should only contain the names of selected channel.parameter combination
4. Remove the list element or value from the list if the user deselects a statistic, parameter or channel

The app unit looks like this: screeenshot

In this case the expected output would be a list that looks like this:

$SWS.Height
[1] "Sum" "Max"

$SWS.Total
[1] "Sum" "Max"

$FL.Red.Height
[1] "Mean"  "Stdev"

$FL.Red.Width
[1] "Mean"  "Stdev"

App: so far only prints what is selected

library(shiny)
Channels <- c('SWS', 'FWS', 'FL.Red', 'FL.Orange', 'FL.Yellow')
Parameters <- c('Height', 'Width', 'Average', 'Total', 'Slope', 'Fill.Factor', 'Correlation.Coeff', 'Fill.Factor')
ui <- fluidPage(

  h5('Channels', style = 'font-weight:bold'),
  fluidRow(
    lapply(Channels, function(x) {
            column(2, checkboxInput(inputId = paste('Channel', x, sep = ''), label = x))
    })
 ),
 h5('Parameters', style = 'font-weight:bold'),
  fluidRow(
  lapply(Channels, function(x) {
    column(2, 
           checkboxGroupInput(inputId = paste("Parameters", x, sep = ''), label = NULL, choiceValues =Parameters, 
                              choiceNames = gsub('\\.', '\\ ', Parameters)) )})
  ),
 h5('Statistics', style = 'font-weight:bold'),

 fluidRow(
   lapply(Channels, function(x) {
     column(2, 
  checkboxGroupInput(paste("Calculations", x, sep = ''), label = NULL, c('Sum', 'Mean', 'Stdev', 'Max', 'Coef.Var'))
 )
   })
 )
)


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

  values <- reactiveValues(Statisticlist = list())
## build observer to deselect all sub category checkboxes if channel is deselected
  lapply(Channels, function(x) {
    observeEvent(input[[paste('Channel', x, sep = '')]], { 
                 if(!input[[paste('Channel', x, sep = '')]]) { 
                  updateCheckboxGroupInput(session, inputId = paste("Parameters", x, sep = ''), selected=character(0))
                  updateCheckboxGroupInput(session, inputId = paste("Calculations", x, sep = ''), selected=character(0))

                  }
              })
  })

   ## attempt to fill named list with selection, and remove it when deselected 
  observe({ 
    lapply(Channels, function(x) {
     if(input[[paste('Channel', x, sep = '')]]) {
       if(!is.null(input[[paste("Parameters", x, sep = '')]])) {
         if(!is.null(input[[paste("Calculations", x, sep = '')]])) {
      print(paste(x, input[[paste("Parameters", x, sep = '')]], sep = '.'))
       print(input[[paste("Calculations", x, sep = '')]])

       # values$Statisticlist <- list(paste(x, input[[paste("Parameters", x, sep = '')]], sep = '.') = input[[paste("Calculations", x, sep = '')]])  ## what to do here....
         }
       }
     }
    })
  })
}

shinyApp(ui, server)




Aucun commentaire:

Enregistrer un commentaire