在一行中排列 3 个动态输入数，并根据第三列对两列输入进行操作

Question

我正在构建一个闪亮的应用程序来映射两个不同的文本输入。我使用字符串距离进行匹配，但它们可能是错误的。因此，我计划开发一个闪亮的应用程序，主题专家可以使用单击和下拉菜单来选择匹配的唯一数据。

如果我有固定的行数，我可以实现如下所示:: 但是，当我不知道数据中的行数时，如何动态设计用户界面以获得所需的输出？

在用户执行了所需的映射之后。我想在单击按钮后执行一些操作。此外，如果用户单击了映射（复选框）。我想将该行排除在最终操作之外。

library(shiny)
set.seed(42)
n_samp = 5 # this comes from the input
indx <- sample(1:20, n_samp)

let_small <-  letters[indx]
let_caps  <-  sample(LETTERS[indx])

# user input
ui <- fluidPage(
  selectInput(inputId = "n_samp_choice", label = NULL, 
              choices = 1:20, width = 500), # number of samples
  fluidRow( # first row checkbox
    column(width = 2, offset = 0,
           checkboxInput("correct1", label = NULL, FALSE)
    ),
    column(width = 2, offset = 0,  # text input originial
           textInput(inputId = "original1", value = let_small[1], label = NULL )
    ),
    column(width = 5, # options for match
           selectInput(inputId = "options1", label = NULL, 
                       choices = let_caps, width = 500)
    )
  ), 
  fluidRow( 
    column(width = 2, offset = 0,
           checkboxInput("correct1", label = NULL, FALSE)
    ),
    column(width = 2, offset = 0,
           textInput(inputId = "original2", value = let_small[2], label = NULL )
    ),
    column(width = 5,
           selectInput(inputId = "options2", label = NULL, 
                       choices = let_caps, width = 500)
    )
  ), 
  fluidRow(
    column(width = 2, offset = 0,
           checkboxInput("correct1", label = NULL, FALSE)
    ),
    column(width = 2, offset = 0,
           textInput(inputId = "original3", value = let_small[3], label = NULL )
    ),
    column(width = 5,
           selectInput(inputId = "options3", label = NULL, 
                       choices = let_caps, width = 500)
    )
  ), 
  fluidRow(
    column(width = 2, offset = 0,
           checkboxInput("correct1", label = NULL, FALSE)
    ),
    column(width = 2, offset = 0,
           textInput(inputId = "original4", value = let_small[4], label = NULL )
    ),
    column(width = 5,
           selectInput(inputId = "options4", label = NULL, 
                       choices = let_caps, width = 500)
    )
  ), 
  fluidRow(
    column(width = 2, offset = 0,
           checkboxInput("correct1", label = NULL, FALSE)
    ),
    column(width = 2, offset = 0,
           textInput(inputId = "original5", value = let_small[5], label = NULL )
    ),
    column(width = 5,
           selectInput(inputId = "options5", label = NULL, 
                       choices = let_caps, width = 500)
    ),
    column(width = 2, offset = 0,
           uiOutput("actionBut.out")
    )
  )
)


server <- function(input, output, session) {
  output$actionBut.out <- renderUI({
    print(input$original1)
    session$sendCustomMessage(type="jsCode",
                              list(code= "$('#text').prop('disabled',true)"))
    actionButton("copyButton1","Copy Code")
  })

  observeEvent(input$copyButton1, {

    if(tolower(input$options1) == tolower(input$options1) &
       tolower(input$options2) == tolower(input$options2) &
       tolower(input$options3) == tolower(input$options3) &
       tolower(input$options4) == tolower(input$options4) &
       tolower(input$options5) == tolower(input$options5))
    {
      print("great job")
    }else{
      unmapp <-  which(c(input$correct1, input$correct2, 
                         input$correct3, input$correct4, 
                         input$correct5))
      print("The following are unmatched")
      print(let_caps[unmapp])
    }
  })

}

shinyApp(ui = ui, server = server)

Answer 1

您可以使用Shiny Modules 和UIOutput 创建动态设计。

Step1：创建一个被循环调用的模块：

moduleUI <- function(id) {
  ns <- NS(id)

  tagList(
    fluidRow( # first row checkbox
      column(width = 2, offset = 0,
             checkboxInput(ns("correct"), label = NULL, FALSE)
      ),
      column(width = 2, offset = 0,  # text input originial
             textInput(inputId = ns("original"), value = let_small[id], label = NULL )
      ),
      column(width = 5, # options for match
             selectInput(inputId = ns("options"), label = NULL, 
                         choices = let_caps, width = 500)
      )
    )
  )
}

第二步：创建一个UIOutput，作为模块的占位符。

uiOutput("module_placeholder")

Step3：添加服务器逻辑：

我添加了一个numericInput，允许您模拟不同的行数。 E.g.: 如果设置为 5，模块会生成 5 次。

这个observer 允许您生成任意数量的模块实例。

observe( {
    output$module_placeholder <- renderUI( {
      lapply(1:input$num, moduleUI)
    })
  })

对象的ids 将是1-correct、1-original、1-options 用于第一个模块，2-correct、2-original 等用于第二个模块，...

这很重要，因为您可以使用 input[[NAME_OF_THE_ELEMENT]] 访问输入元素。

例如，我使用lapply 检查每个模块是否有input$original == input$options。 （类似于您的代码，但它是通用的，因此适用于任意数量的模块）

cond <- unlist(lapply(to_check, function(x) {
  tolower(input[[paste(x, "original", sep="-")]]) == tolower(input[[paste(x, "options", sep="-")]])
}))

查看完整代码：

library(shiny)
set.seed(42)
n_samp = 10 # this comes from the input
indx <- sample(1:20, n_samp)

let_small <-  letters[indx]
let_caps  <-  sample(LETTERS[indx])


moduleUI <- function(id) {
  ns <- NS(id)

  tagList(
    fluidRow( # first row checkbox
      column(width = 2, offset = 0,
             checkboxInput(ns("correct"), label = NULL, FALSE)
      ),
      column(width = 2, offset = 0,  # text input originial
             textInput(inputId = ns("original"), value = let_small[id], label = NULL )
      ),
      column(width = 5, # options for match
             selectInput(inputId = ns("options"), label = NULL, 
                         choices = let_caps, width = 500)
      )
    )
  )
}

ui <- fluidPage(
  numericInput(inputId = "num", label = "Select number of modules", value = 1, min = 1),
  selectInput(inputId = "n_samp_choice", label = NULL, 
              choices = 1:20, width = 500), # number of samples
  uiOutput("module_placeholder"),
  uiOutput("actionBut.out")
)


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

  observe( {
    output$module_placeholder <- renderUI( {
      lapply(1:input$num, moduleUI)
    })
  })

  output$actionBut.out <- renderUI({
    print(input$original1)
    session$sendCustomMessage(type="jsCode",
                              list(code= "$('#text').prop('disabled',true)"))
    actionButton("copyButton","Copy Code")
  })

  observeEvent(input$copyButton, {
    checked <- unlist(lapply(1:input$num, function(x) {
      if(input[[paste(x, "correct", sep="-")]]) x
    }))

    if(length(checked) == 0) {
      to_check <- 1:input$num
    } else {
      to_check <- (1:input$num)[-checked]
    }

    cond <- unlist(lapply(to_check, function(x) {
      tolower(input[[paste(x, "original", sep="-")]]) == tolower(input[[paste(x, "options", sep="-")]])
    }))

    if(all(cond)) {
      print("great job")
    } else {
      unmapp <-  which(!cond)
      optns <- unlist(lapply(1:input$num, function(x) {
        input[[paste(x, "options", sep="-")]]
      }))
      print("The following are unmatched")
      print(optns[to_check][unmapp])
    }
  })
}

shinyApp(ui = ui, server = server)

Answer 2

 uiOutput("mappings")

你现在有输入的地方，你在服务器中放置类似这样的东西

output$mappings <- renderUI({
  tagList(
    lapply(
      1:length(someList),
      function(idx){
        fluidRow( # first row checkbox
          column(width = 2, offset = 0,
                 checkboxInput(paste0("correct",idx), label = NULL, FALSE)
          ),
          column(width = 2, offset = 0,  # text input originial
                 textInput(inputId = paste0("original",idx), value = let_small[1], label = NULL )
          ),
          column(width = 5, # options for match
                 selectInput(inputId = paste0("options",idx), label = NULL, 
                             choices = let_caps, width = 500)
          )
        )
      }
    )
  )
})

然后获取您可以执行类似操作的值

observe({
  lapply(
    1:length(someList),
    function(idx){input[[paste0("correct",idx)]]}
  )
})

以你的为例，它可能看起来像这样

library(shiny)
set.seed(42)
n_samp = 5 # this comes from the input
indx <- sample(1:20, n_samp)

let_small <-  letters[indx]
let_caps  <-  sample(LETTERS[indx])

# user input
ui <- fluidPage(
  selectInput(inputId = "n_samp_choice", label = NULL, 
              choices = 1:20, width = 500), # number of samples
  uiOutput("mappings"),

)


server <- function(input, output, session) {
  output$actionBut.out <- renderUI({
    print(input$original1)
    session$sendCustomMessage(type="jsCode",
                              list(code= "$('#text').prop('disabled',true)"))
    actionButton("copyButton1","Copy Code")
  })
  output$mappings <- renderUI({
    tagList(
      lapply(
        1:5,
        function(idx){
          fluidRow( # first row checkbox
            column(width = 2, offset = 0,
                   checkboxInput(paste0("correct",idx), label = NULL, FALSE)
            ),
            column(width = 2, offset = 0,  # text input originial
                   textInput(inputId = paste0("original",idx), value = let_small[idx], label = NULL )
            ),
            column(width = 5, # options for match
                   selectInput(inputId = paste0("options",idx), label = NULL, 
                               choices = let_caps, width = 500)
            )
          )
        }
      )
    )
  })

  lapply(
    1:5,
    function(idx){
      observeEvent(input[[paste0("options",idx)]],
                   {
                     print(input[[paste0("options",idx)]])
                   },
                   ignoreInit = TRUE)
    }
  )
  observeEvent(input$copyButton1, {

    if(tolower(input$options1) == tolower(input$options1) &
       tolower(input$options2) == tolower(input$options2) &
       tolower(input$options3) == tolower(input$options3) &
       tolower(input$options4) == tolower(input$options4) &
       tolower(input$options5) == tolower(input$options5))
    {
      print("great job")
    }else{
      unmapp <-  which(c(input$correct1, input$correct2, 
                         input$correct3, input$correct4, 
                         input$correct5))
      print("The following are unmatched")
      print(let_caps[unmapp])
    }
  })

}

shinyApp(ui = ui, server = server)