r - 如何在 Shiny 中使用 purrr 将一个 renderText 应用于多个输出？

Question

我有一系列 textAreaInput，每个都需要在“下一步”按钮下方有一个友好的提醒来填写字段。 (实际上，每个字段和按钮都位于单独的选项卡上。)我使用 renderText 在每个按钮下方输出提醒。我可以复制并粘贴每个 textOutput 的 renderText 函数，但我有两个以上，所以我觉得我违反了 golden rule.

Purrr 似乎是一个合适的工具。我怀疑解决方案将类似于 here和 here但我无法将这些解决方案应用于我的问题。

如何将相同的 renderText 函数应用于每个 textOutput？ 我更喜欢 purrr，但我很欣赏学习替代解决方案。

library(shiny)
library(purrr)

ui <- fluidPage(
  fluidRow(
    column(3,
      textAreaInput(inputId = "ta1", 
                    label = "Fill in this field."),
      actionButton(inputId = "btn_next_ta1", label = "Next"),
      textOutput("ta1_error")
      ),
    column(3,
      textAreaInput(inputId = "ta2",
                    label = "Fill in this field."),
      actionButton(inputId = "btn_next_ta2", label = "Next"),
      textOutput("ta2_error")
    ),
  )
)

server <- function(input, output) {
  
  # Is this even close to a suitable start?
  # walk(c("ta1", "ta2"), ~ observeEvent(input[[.x]], error_check(.x)))
                                              
  error_check <- function(x) {
    # Need to render the text string and assign
    # to each textOutput
    # if (x == "") {
    #   renderText("Please fill in the field."}
  }
  
  # ERROR CHECKS that I want to replace 
  # with a single function.
  output$ta1_error <- renderText({
    if (input$ta1 == "") {
      "Please fill in the field."
    }
  })
  
  output$ta2_error <- renderText({
    if (input$ta2 == "") {
      "Please fill in the field."
    }
  })
}

shinyApp(ui = ui, server = server)

^{由 reprex package 于 2021 年 11 月 4 日创建(v2.0.1)}

Answer 1

老问题，但是:

lapply 版本(可以用 purrr::map 替换):

library(shiny)

textAreaInputIDs <- paste0("ta", 1:2)

ui <- fluidPage(
  fluidRow(
    lapply(textAreaInputIDs, function(id){
      column(3,
             textAreaInput(inputId = id, 
                           label = "Fill in this field."),
             actionButton(inputId = paste0("btn_next_", id), label = "Next"),
             textOutput(paste0(id, "_error"))
      )
    })
  )
)

server <- function(input, output) {
  lapply(textAreaInputIDs, function(id){
    output[[paste0(id, "_error")]] <- renderText({
      if (input[[id]] == "") {
        "Please fill in the field."
      }
    })
  })
}

shinyApp(ui = ui, server = server)

但是，通常 shiny's modules旨在通过专用命名空间处理这样的场景:

library(shiny)

textAreaInputUI <- function(id) {
  ns <- NS(id)
  column(3,
         textAreaInput(inputId = ns("ta"), 
                       label = "Fill in this field."),
         actionButton(inputId = ns("btn_next_ta"), label = "Next"),
         textOutput(ns("ta_error"))
  )
}

textAreaInputServer <- function(id) {
  moduleServer(
    id,
    function(input, output, session) {
      output$ta_error <- renderText({
        if (input$ta == "") {
          "Please fill in the field."
        }
      })
    }
  )
}

ui <- fluidPage(
  fluidRow(textAreaInputUI("ta1"),
           textAreaInputUI("ta2")
  )
)

server <- function(input, output, session) {
  textAreaInputServer("ta1")
  textAreaInputServer("ta2")
}

shinyApp(ui, server)

PS:另请查看shinyvalidate .