从元素的动态输入数量创建动态数量的输出 ui 元素

Question

我正在尝试减少renderUI和reactive的输入和输出的一些重复功能，以便使用purrr使代码更简单。 我发现试图用 pmap 制作一个版本，但它似乎不起作用。 您能否提供一些见解或方法来了解如何调试它？

repo

桌子

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

功能

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()  
}

用户界面

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

服务器工作

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))
    )
  )
}

尝试通过 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]])) 
    }
  )

}

错误信息

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

我猜你可以尝试使用闪亮的modules。

但我认为在您的代码中更新可用选项的方式存在缺陷。如果用户首先选择魅力，其他属性的可用选项将不会更新。解决此问题的一种方法是使用 dra-and-drop 包，例如 sortable package 或 dragndrop。选择一行将更新拖放值，然后用户将选择放置每个值的位置。