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

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

uiOutput("module_placeholder")

Step3 ：添加服务器逻辑：

我添加了一个numericInput，可以让您模拟不同的行数。例如：如果将其设置为5，模块将生成5次。

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

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

第一个模块id，1-correct等对象的1-original个为1-options，2-correct，2-original 。对于第二个模块，......

这很重要，因为您可以使用输入[[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

map

现在您可以在服务器中输入类似的内容

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

根据第三列

2 个答案: