Creating a dynamic number of output ui elements from dynamic input number of elements

Question

I'm trying to reduce some repetitive functions for input and output of renderUI and reactive in order to make more simple the code using purrr. I found tried to make a version with pmap but it doesn't seem to work. Could you provide me with some insight or a way to understand how to debug it?

The repo

the table

library('tidyverse')
library('data.table')
library("shiny")

Attr_scores <- structure(list(scope = c("Sel1", "Sel2", "Sel3", "Sel4", "Sel5", 
"Sel6", "Sel7", "Sel8", "Sel9", "Sel10", "Sel11", "Sel12", "Sel13"
), A1 = c(14, 14, 14, 15, 15, 15, 16, 16, 16, 17, 17, 17, 18), 
    A2 = c(13, 14, 14, 14, 15, 15, 13, 14, 16, 14, 15, 17, 12
    ), A3 = c(13, 13, 14, 13, 12, 15, 12, 14, 10, 12, 11, 8, 
    12), A4 = c(13, 13, 13, 12, 12, 11, 12, 10, 10, 10, 11, 8, 
    10), A5 = c(13, 13, 10, 12, 11, 8, 12, 10, 10, 10, 10, 8, 
    10), A6 = c(12, 10, 8, 11, 11, 8, 12, 10, 10, 10, 8, 8, 10
    )), row.names = c(NA, -13L), class = c("tbl_df", "tbl", "data.frame"
))

the functions

Attr_score_select <- function(y){
  Attr_scores %>% 
    as.data.table() %>% 
    .[y] %>% 
    pivot_longer(-scope) %>% 
    count(value)
}

## change the number of the score you still have
Attr_score_remove <- function(df, score){
    df %>% 
        mutate(n = ifelse(value == score, n-1, n)) %>% 
        mutate(n = ifelse(n == 0, NA, n)) %>% 
        drop_na()  
}

the ui

ui <- fluidPage(
    titlePanel("Create your Character:"), 
  navlistPanel(
   "Header B",
    tabPanel("Main Attributes",
      sidebarPanel(
     "Attributes",   

        # select the values for each attr
    c("Strength_ui", "Dexterity_ui",
     "Constitution_ui","Intelligence_ui",
      "Wisdom_ui","Charisma_ui") %>% 
          map(~uiOutput(.x))
      ),
      mainPanel( 
       # table with Attributes score
       h4("Select the row with the Attribute scores for your character:"),
       DT::dataTableOutput("table"))
      ),

    "-----",
    tabPanel("Component 4"),
    "-----",
    tabPanel("Component 5")
  )
)

the server working

server <- function(input, output) {
  output$table <- DT::renderDataTable(
    DT::datatable(
      data = Attr_scores, 
      style = 'bootstrap', 
      options = list(pageLength = 10),
      selection = "single"))
  Scores <- reactive(Attr_score_select(input$table_row_last_clicked))

  output$Strength_ui <- renderUI({
    #Strength
           selectInput('Strength_1', 
                       label = "Choose Strength score for your character:", 
                       c(Choose='', 
                         as.character(Scores()$value))
           )
  })
  Scores1 <- reactive(Scores() %>%
                        Attr_score_remove(input$Strength_1))
  #Dexterity
  output$Dexterity_ui = renderUI(
    selectInput('Dexterity_1',
                label = "Choose Dexterity score for your character:",
                c(Choose='', as.character(Scores1()$value))
    )
  )
  Scores2 <- reactive(Scores1() %>%
                        Attr_score_remove(input$Dexterity_1))
  #Constitution
  output$Constitution_ui = renderUI(
    selectInput('Constitution_1',
                label = "Choose Constitution score for your character:",
                c(Choose='', as.character(Scores2()$value))
    )
  )
  Scores3 <- reactive(Scores2() %>%
                        Attr_score_remove(input$Constitution_1))
  #Intelligence
  output$Intelligence_ui = renderUI(
  selectInput('Intelligence_1', 
              label = "Choose Intelligence score for your character:", 
              c(Choose='', as.character(Scores3()$value) )
    )
  )
  Scores4 <- reactive(Scores3() %>%
                        Attr_score_remove(input$Intelligence_1))
  #Wisdom
  output$Wisdom_ui = renderUI(
  selectInput('Wisdom_1', 
              label = "Choose 'Wisdom score for your character:", 
              c(Choose='', as.character(Scores4()$value) )
              )
  )
  Scores5 <- reactive(Scores4() %>%
                        Attr_score_remove(input$Wisdom_1))
  #Charisma
  output$Charisma_ui = renderUI(
  selectInput('Charisma_1', 
              label = "Choose 'Charisma score for your character:", 
              c(Choose='', 
                as.character(Scores5()$value))
    )
  )
}

attempt to reduce duplication through tidyverse

Scores <- list(
  "Strength_ui",
  "Dexterity_ui",
  "Constitution_ui",
  "Intelligence_ui",
  "Wisdom_ui",
  "Charisma_ui"
) %>% set_names(.)


server <- function(input, output) {

  output$table <- DT::renderDataTable(
    DT::datatable(
      data = Attr_scores, 
      style = 'bootstrap', 
      options = list(pageLength = 10),
      selection = "single"))
  Scores[["Strength_ui"]] <- reactive(
  Attr_score_select(input$table_row_last_clicked))


  pmap(..1 = names(Scores), ..2 = names(Scores) %>% seq_along(),
    ..3 = c("Strength_1", "Dexterity_1",
      "Constitution_1","Intelligence_1",
      "Wisdom_1","Charisma_1"),
  .f = ~ function(x, y, z){
    output[[..1]] <- renderUI({
      selectInput(..3,
        label = str_c("Choose",str_remove(..1,"_ui") ,
          "score for your character:"),
        c(Choose='',as.character(Scores[[..1]]()$value))
        )
      })

    Scores[[..2+1]] <- reactive(Scores[[..1]]() %>%
                        Attr_score_remove(input[[..3]])) 
    }
  )

}

error message

shinyApp(ui = ui, server = server)

Listening on http://127.0.0.1:3295
Warning: Error in is.data.frame: argument ".l" is missing, with no default
  54: is.data.frame
  53: pmap
  52: server [#13]
Error in is.data.frame(.l) : argument ".l" is missing, with no default

Answer 1

I guess you could try using shiny modules .

But I think there is a flaw in the way the available choices are being updated in your code. If the user chooses Charisma first, the choices available for the other attributes won´t be updated. One way to work around this issue would be using a dra-and-drop package, like sortable package or dragndrop. Selecting a row would update the drag-and-drop values, and the user would then choose where to place each one of them.