nesting interactive UI in shiny

shiny
,
1

I am trying to create an interactive userinterface with shiny. Based on the first selection it creates a tabset, and in that tabset based on a second selection is created another ui. The code below works, but I can't figure out how I could replace the X=1:10 to 1:n() on line 81...

Thank you for any suggestions :slight_smile:

library(shiny)

# constants for example

factors <- LETTERS[1:10]

factor_values <- c()
for(i in factors){
  factor_values[[i]] <- paste0(i,1:5)    
}

samples <- paste0("sample_",1:10)

# UI

ui <- fluidPage(
  h3("Choose factors"),
  selectizeInput("factor","Select all known factors:",factors, multiple=TRUE),
  tags$br(),
  uiOutput("tabset"),
  actionButton("btn","print stuff that's happening, cause wtf...")
)



# server
server <- function(input, output, session){
  
  factor_val_list <- reactive({
    req(input$factor)
    f <- input$factor
    l <- c()
    for( i in 1:length(f) ){
      l[[i]] <- factor_values[[f[i]]]
    }
    return(l)
  })
  
  
  ui_tabset_factor <- reactive({
    req(input$factor)
    # list of chosen factors 
    factor <- input$factor
    l <- c()
    for(i in 1:length(factor)){
      tab <- paste0(
        "tabPanel('",factor[i],"', tags$br(),
        selectizeInput(
        inputId = 'fv_", i,"',
        label=p('Select all different values for the factor in the experiment: '),
        choices=factor_val_list()[[",i,"]], 
        multiple=TRUE),
        checkboxInput('",paste0("check_",i),"','Check this box when the list is complete.'),
        tags$br(),
        p('Assign the samples to the right category:'),
        tags$div(id = 'placeholder_",i,"') 
      )")
      # create list of tabpanels from chosen factors
      l <- append(l, tab)
    }
    # seperate them with comma's
    tabs <- paste(l, collapse=",")
    # create tabsetpanel with created tabs
    ui <- paste0("tabsetPanel(type = 'tabs',",tabs,")")
  })
  
  
  output$tabset <- renderUI({
    # renderUI from text creating tabsetpanel
    eval(parse(text=ui_tabset_factor()))
  })
  
  
  n <- reactive({
    req(input$factor)
    length(input$factor)
  })
  
  # insert UI 
  lapply(
    X = 1:10,
    FUN = function(i){
      observeEvent(input[[paste0("check_",i)]], {
        id <- paste0('div_', i)
        if(input[[paste0("check_",i)]] == 1){
          insertUI(
            selector = paste0('#placeholder_',i),
            ## wrap element in a div with id for ease of removal
            ui = tags$div(
              selectInput(paste0("sample_",i),"Choose sample",samples),
              id = id
            )
          )
        } else {
          removeUI(
            # pass in appropriate div id
            selector = paste0('#div_',i)
          )
          
        }
      }, ignoreInit = TRUE)
    }
  )
  
  
  observeEvent(input$btn,{
    print(n())
  })
  
  session$onSessionEnded(function(session){
    # stop the application
    stopApp()
  })
  
  
}
shinyApp(ui = ui, server = server)
2

wouldn't it be

1:length(factors)

?

1 Like
3

Hi nirgrahamuk,
thank you for taking the time to look at my question.

I only want to calculate it for the selected ones, and the complete list of factors in the actual app would not be a constant but also a reactive value fetched from a database.

4

ok, so that would be defined by the contents of the input$factors, and you defined a reactive called n(), (i think this should be renamed factors_n() so it doesn't conflict/confuse with dplyr function n().
but 1:n() should therefore work. though might need to 'defend' on n() not havving been set, by wrapping it with a req(n()) to require it ?
but i think best to rename so its not n

1 Like
5

then I get the error:
"Error in .getReactiveEnvironment()$currentContext() :
Operation not allowed without an active reactive context. (You tried to do something that can only be done from inside a reactive expression or observer.)"

And if if I try to put it in a reactive function I don't know how to get it executed.
I've also tried putting it in an observeEvent(input$factor,{...}) but then it creates an extra selectinput every time input$factor changes.

6

I've also tried fixing it by adding another checkbox to indicate the list of selected factors is complete,
but if the user uncheck and checks it again it's the same issue, multiple selectinputs are created.

I don't fully understand the insertUI function...

7

hey ok.
i renamed n to n_factor,
need to wrap the lapply inside of an observe so its reactive to changes on n_factor

  n_factor <- reactive({
    req(input$factor)
    length(input$factor)
  })
  

observe({
  # insert UI 
  lapply(
    X = 1:n_factor(),
    FUN = function(i){
      observeEvent(input[[paste0("check_",i)]], {
        id <- paste0('div_', i)
        if(input[[paste0("check_",i)]] == 1){
          insertUI(
            selector = paste0('#placeholder_',i),
            ## wrap element in a div with id for ease of removal
            ui = tags$div(
              selectInput(paste0("sample_",i),"Choose sample",samples),
              id = id
            )
          )
        } else {
          removeUI(
            # pass in appropriate div id
            selector = paste0('#div_',i)
          )
          
        }
      }, ignoreInit = TRUE)
    }
  )
})
  
  observeEvent(input$btn,{
    print(n_factor())
  })
1 Like
8

This way it is also creating more selectinputs every time something changes in input$factor

9

it overwrites with the check_i names though. you wont get more than n_factor number of inputs, where the n_factor reduces the ones below the number will be overwritten. I suppose you could keep track of the maximimum inputs you ever had n_factor rise to, and then Null out the inputs with those numbers greater than n_factor but less than the max of n_factors history.
I was trying to do the minimal changes to implement your code, I don't exactly understand your intent as well as you do :slight_smile:

1 Like
10

I don't really understand what you mean.
Is there a way to have the removeUI do it's job before every update?

I have a more extended example here:

# library(devtools)
# devtools::install_github("daattali/chooserInput")

library(shiny)
library(chooserInput)

# functions for creating ui from reactive values with loop

# create headers in fluidRow columns from list of headers (for combi chooserinput)
ui_header <- function(list){
  req(list)
  l_header <- c()
  n <- length(list)
  for(i in 1:n){
    l_header <-append(l_header,paste0(
      "column(",floor(12/n),", p('",list[i],"'))"))
  }
  x<-paste(l_header,collapse=",")
  header<-paste0("fluidRow(",x,")")
  return(header)
}

# create chooserinput in fluidrow from list
# results will be in input$chooser_listitem
ui_chooserinput <- function(list, choices){
  req(list)
  n <- length(list)
  # remove commas and spaces from name for inputID
  list <- lapply(list, function(x) gsub(" ","_",x))
  list <- lapply(list, function(x) gsub(",","",x))
  opt <- paste0("c('",paste(choices,collapse="','"),"')")
  # if there is only one option, select all samples
  if(n == 1){
    x <- paste0(
      "column(",floor(12/n),", chooserInput('chooser_",list,"', 'Available', 'Selected',
      c(), ",opt,", numLines = 10, multiple = TRUE ))")
  } else {
    l_in<-c()
    for(i in 1:n){
      l_in <- append(l_in,paste0(
        "column(",floor(12/n),", chooserInput('chooser_",list[i], "', 'Available', 'Selected',
        ",opt,", c(), numLines = 10, multiple = TRUE ))"))
    }
    x<-paste(l_in,collapse=",")
  }
  select_sample<-paste0("fluidRow(",x,")")
  return(select_sample)
}

# constants for example

factors <- LETTERS[1:10]

factor_values <- c()
for(i in factors){
  factor_values[[i]] <- paste0(i,1:5)    
}

samples <- paste0("sample_",1:10)

# UI

ui <- fluidPage(
    h3("Choose factors"),
    selectizeInput("factor","Select all known factors:",factors, multiple=TRUE),
    tags$br(),
    uiOutput("tabset"),
    actionButton("btn","print stuff that's happening, cause wtf...")
  )



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

    factor_val_list <- reactive({
    req(input$factor)
    f <- input$factor
    l <- c()
    for( i in 1:length(f) ){
      l[[i]] <- factor_values[[f[i]]]
    }
    return(l)
  })
  

  ui_tabset_factor <- reactive({
    req(input$factor)
    # list of chosen factors 
    factor <- input$factor
    l <- c()
    for(i in 1:length(factor)){
      tab <- paste0(
        "tabPanel('",factor[i],"', tags$br(),
         selectizeInput(
          inputId = 'fv_", i,"',
          label=p('Select all different values for the factor in the experiment: '),
          choices=factor_val_list()[[",i,"]], 
          multiple=TRUE),
        checkboxInput('",paste0("check_",i),"','Check this box when the list is complete.'),
        tags$br(),
        p('Assign the samples to the right category:'),
        tags$div(id = 'placeholder_",i,"') 
                    )")
      # create list of tabpanels from chosen factors
      l <- append(l, tab)
    }
    # seperate them with comma's
    tabs <- paste(l, collapse=",")
    # create tabsetpanel with created tabs
    ui <- paste0("tabsetPanel(type = 'tabs',",tabs,")")
  })
  

  output$tabset <- renderUI({
    # renderUI from text creating tabsetpanel
    eval(parse(text=ui_tabset_factor()))
  })
  
  
  n_factor <- reactive({
    req(input$factor)
    length(input$factor)
  })
  
  # insert UI chooserinput
  observe({
    lapply(
      X = 1:n_factor(),
      #X = 1:10,
      FUN = function(i){
        observeEvent(input[[paste0("check_",i)]], {
          id <- paste0('div_', i)
          if(input[[paste0("check_",i)]] == 1){
            insertUI(
              selector = paste0('#placeholder_',i),
              ## wrap element in a div with id for ease of removal
              ui = tags$div(
                eval(parse(text = ui_header(input[[paste0("fv_",i)]]))),
                eval(parse(
                  text = ui_chooserinput(input[[paste0("fv_",i)]],samples)
                )),
                id = id
              )
            )
          } else {
            removeUI(
              ## pass in appropriate div id
              selector = paste0('#div_',i)
            )
            
          }
        }, ignoreInit = TRUE)
      }
    )
  })
  
  
  # # working example chooserinput
  # output$ui_fv1 <- renderUI({
  #   req(input$factor_val_1)
  #   eval(parse(text = ui_header(input$factor_val_1)))
  # })
  # 
  # 
  # output$ui_fv2 <- renderUI({
  #   req(input$factor_val_1)
  #   eval(parse(
  #     text = ui_chooserinput(input$factor_val_1,samples_in_exp2()[,"Sample"])
  #   ))
  # })
  
  # works fine
  observeEvent(input$btn,{
    #print(ui_tabset_factor())
    print(n_factor())
  })
  
  session$onSessionEnded(function(session){
    # stop the application
    stopApp()
  })


}
shinyApp(ui = ui, server = server)
11

So I've gotten the result I want by calling removeUI before insertUI.
It works but it feels fiddly and it is doing a lot more work than it should.
Could this cause performance issues later for my app?

library(shiny)


# constants for example

factors <- LETTERS[1:10]

factor_values <- c()
for(i in factors){
  factor_values[[i]] <- paste0(i,1:5)    
}

samples <- paste0("sample_",1:10)

# UI

ui <- fluidPage(
  h3("Choose factors"),
  selectizeInput("factor","Select all known factors:",factors, multiple=TRUE),
  checkboxInput("factor_ready","Check this box when the list is complete."),
  tags$br(),
  uiOutput("tabset"),
  actionButton("btn","print stuff that's happening, cause wtf...")
)



# server
server <- function(input, output, session){
  
  factor_val_list <- reactive({
    req(input$factor)
    f <- input$factor
    l <- c()
    for( i in 1:length(f) ){
      l[[i]] <- factor_values[[f[i]]]
    }
    return(l)
  })
  
  
  ui_tabset_factor <- reactive({
    req(input$factor)
    # list of chosen factors 
    factor <- input$factor
    l <- c()
    for(i in 1:length(factor)){
      tab <- paste0(
        "tabPanel('",factor[i],"', tags$br(),
        selectizeInput(
        inputId = 'fv_", i,"',
        label=p('Select all different values for the factor in the experiment: '),
        choices=factor_val_list()[[",i,"]], 
        multiple=TRUE),
        checkboxInput('",paste0("check_",i),"','Check this box when the list is complete.'),
        tags$br(),
        p('Assign the samples to the right category:'),
        tags$div(id = 'placeholder_",i,"') 
      )")
      # create list of tabpanels from chosen factors
      l <- append(l, tab)
    }
    # seperate them with comma's
    tabs <- paste(l, collapse=",")
    # create tabsetpanel with created tabs
    ui <- paste0("tabsetPanel(type = 'tabs',",tabs,")")
  })
  
  
  output$tabset <- renderUI({
    # renderUI from text creating tabsetpanel
    eval(parse(text=ui_tabset_factor()))
  })
  
  n_factor <- reactive({
    req(input$factor)
    length(input$factor)
  })
  
  
  observe({
    # insert UI 
    lapply(
      X = 1:n_factor(),
      FUN = function(i){
        observeEvent(input[[paste0("check_",i)]], {
          id <- paste0('div_', i)
          if(input[[paste0("check_",i)]] == TRUE){
            # removeUI if exists
            removeUI(
              # pass in appropriate div id
              selector = paste0('#div_',i)
            )
            insertUI(
              selector = paste0('#placeholder_',i),
              ## wrap element in a div with id for ease of removal
              ui = tags$div(
                selectInput(paste0("sample_",i),"Choose sample",samples),
                id = id
              )
            )
          } else {
            removeUI(
              # pass in appropriate div id
              selector = paste0('#div_',i)
            )
            
          }
        }, ignoreInit = TRUE)
      }
    )
  })
  
  observeEvent(input$btn,{
    print(n_factor())
  })
  
  
  observeEvent(input$btn,{
    print(n_factor())
  })
  

  
  session$onSessionEnded(function(session){
    # stop the application
    stopApp()
  })
  
  
  }
shinyApp(ui = ui, server = server)
12

You might find the material in https://mastering-shiny.org/action-dynamic.html helpful for your problem.

1 Like