Question

我创建了一个简单的项目，我在一个模块（选择器）中从列表生成选择输入，返回输入列表。我有另一个模块（查看器），它接受从选择器模块返回的输入，并生成一些与Count selectInput值对应的textOuputs，它们的文本对应于Colors selectInput值。问题是生成的输入无法识别，因此，输入列表不会选择返回。我能够识别它们的唯一方法是，如果我硬编码我不想做的selectInputs（我已经在selectorUI中添加它们作为参考的注释）。

ui.R

library(shiny)
HOME_DIR<-getwd()
source(file.path(HOME_DIR,'subUI.R'),local=TRUE)
shinyUI(fluidPage(
    titlePanel("Sample App"),
    sidebarLayout(
       sidebarPanel(
        selectorUI("selectorModl")
    ),
    mainPanel(
        viewerUI("viewerModl")
    )
)))

server.R

library(shiny)
HOME_DIR<-getwd()
source(file.path(HOME_DIR,'subUI.R'),local=TRUE)
shinyServer(function(input, output) {
    selection <- list("count" = c(1,2,3,4,5), "colors" = c("blue", "green","red"))
    inputValues<-reactive(callModule(selector,"selectorModl", selection))
    observeEvent(inputValues(),{
        if(length(inputValues()))
            callModule(viewer, "viewerModl", inputValues())
    })
})

subUI.R

#----------selector subUI
selectorUI<-function(id){
    ns <- NS(id)
    tagList(
        htmlOutput(ns("selectorPane"))
        # selectInput(ns("count"), label = "count", choices = "", multiple = F)
        # ,selectInput(ns("colors"), label = "colors",choices = "", multiple = F)

    )
}

selector<-function(input, output, session,selection){
    output$selectorPane <- renderUI({
        lapply(1:length(selection), function(selIdx){
            selName <- names(selection)[selIdx]
            selChoices<-selection[[selName]]
            selectInput(inputId = selName, label = selName, choices = selChoices, multiple = F)
        })
    })
    observe({
        print(names(input))
        if(!is.null(input[["count"]])){
            if(input[["count"]]==""){
                lapply(1:length(selection), function(selIdx){
                    selName <- names(selection)[selIdx]
                    selChoices<-selection[[selName]]
                    updateSelectInput(session, inputId = selName, choices = selChoices)
                })
            }    
        }
    })
    return(input)
}

#----------viewer subUI
viewerUI<-function(id){
    ns <- NS(id)
    uiOutput(ns("viewerPane"))
}

viewer<-function(input, output, session, inputValues){
    output$viewerPane <- renderUI({
        if(length(inputValues) > 0)
            if(!is.null(inputValues[["count"]]) && inputValues[["count"]] != "" && !is.null(inputValues[["colors"]]))
            lapply(1:inputValues[["count"]], function(idx){
                textInput(paste("text",idx, sep = "_"), label = "", value = inputValues[["colors"]])
            })
    })
}

以下是我想要实现的截图。任何帮助，将不胜感激。谢谢！

Answer 1

在闪亮的应用中创建动态UI有几种方法。您已使用renderUI。您也可以尝试insertUI或conditionalPanel。 conditionalPanel是达到你想要的最简单方法（我认为）。这意味着您不必担心重新创建输入，相关观察者并保持其当前选定的值。 conditionalPanel保持逻辑客户端，这意味着它具有更快的响应并且不会淡入/淡出。示例（没有模块）：

library(shiny)

choices_count <- c(1:10)

ui_conditional <- function(count_i) {
  conditionalPanel(condition = paste0("input.select_count >= ", count_i),
                   textOutput(paste0("text_", count_i))
      )
}

ui <- shinyUI(fluidPage(

  titlePanel("Sample app"),

  sidebarLayout(

    sidebarPanel(
      selectInput("select_count", "Count", choices = choices_count),
      selectInput("select_colour", "Colour", choices = c("blue", "green", "red"))
    ),

    mainPanel(
      lapply(choices_count, ui_conditional)
    )
  )

))

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

  observeEvent(input$select_colour, {
    for (i in choices_count) {
      output[[paste0("text_",i)]] <- renderText(input$select_colour)
    }
  })

}

shinyApp(ui, server)

Answer 2

如果我理解正确，您的问题是了解如何在服务器端生成动态UI组件。

我尝试使用动态组件实现类似于UI示例的内容。

library(shiny)

#------------------------------------------------------------------------------
#
# Any general purpose assignment, available for any session, should be done here or on a sourced file
countLb <- c(1,2,3,4,5)
colorLb <- c("blue", "green","red")

# dynamic elements can potentially live either in a separate file, or here, or in the Server part. 
# Of course they need to be in Server if you change them dynamically!

dynUI <- list(
   selectInput("inputID1", label = "count",  choices = countLb, multiple = F)
 , selectInput("inputID2", label = "colors", choices = colorLb, multiple = F)
)

ui <- fluidPage(
  titlePanel("Sample App"),
  sidebarLayout(
    sidebarPanel(
      uiOutput("selectorModl")
    ),
    mainPanel(
      uiOutput("viewerModl")
    )
  ))

server = function(input, output,session) {


output$selectorModl <- renderUI({
  dynUI
})

output$viewerModl <- renderUI({

   if((length(input$inputID1) == 0) | (length(input$inputID2) == 0)) return()
   isolate({
   toRender <- lapply(1:input$inputID1, function(i) {
     textInput(paste("text",i, sep = "_"), label = "", value = input[["inputID2"]])
   })
   return(toRender)
   }) # end isolate
 })
}

shinyApp(ui,server)

如果我已接近满足您的要求，如果您需要进一步澄清此代码，请告诉我。

Answer 3

我已将此作为单独的答案，以避免混淆代码。

这是一个使用模块和动态UI的工作版本。注意在模块中使用ns <- session$ns。还要注意反应功能。我通常会将变量命名为rfVariableName，以提醒我它是一个反应函数，而不仅仅是一个普通变量。

library(shiny)

# selctor Module ---------------
selectorUI <- function(id) {

  ns <- NS(id)

  uiOutput(ns("selectorPane"))

}

selector <- function(input, output, session, selection) {

  output$selectorPane <- renderUI({

    ns <- session$ns

    tagList(
      lapply(1:length(selection), function(selIdx){
        selName <- names(selection)[selIdx]
        selChoices <- selection[[selName]]
        selectInput(inputId = ns(selName), label = selName, choices = selChoices, multiple = F)
      })
    )

  })

  allInputs <- reactive({
    l <- lapply(1:length(selection), function(getid) {
      selName <- names(selection)[getid]
      input[[selName]]
    })
    names(l) <- names(selection)
    l
  })

  return(allInputs)

}

# Viewer Module ---------------
viewerUI <- function(id) {
  ns <- NS(id)

  uiOutput(ns("viewerPane"))

}

viewer <- function(input, output, session, inputValues) {

  output$viewerPane <- renderUI({

    ns <- session$ns

    if (length(inputValues()) > 0) {
      if (!is.null(inputValues()[["count"]])) {
        if (inputValues()[["count"]] > 0) {
          tagList(
            lapply(1:inputValues()[["count"]], function(idx){
              textInput(ns(paste("text",idx, sep = "_")), label = "", value = inputValues()[["colors"]])
            })
          )
        }
      }
    }

  })

}



# Main UI --------------
ui <- shinyUI(fluidPage(
  titlePanel("Sample App"),
  sidebarLayout(
    sidebarPanel(
      selectorUI("selectorModl")
    ),
    mainPanel(
      viewerUI("viewerModl")
    )
  )))


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

  selection <- list("count" = c(1,2,3,4,5), "colors" = c("blue", "green","red"))

  inputValues <- callModule(selector,"selectorModl", selection = selection)

  observeEvent(inputValues(),{

    if (length(inputValues()) > 0) {
      callModule(viewer, "viewerModl", inputValues = inputValues)
    }

  })

}

shiny::shinyApp(ui, server)

动态创建的selectInputs在服务器中无法识别

3 个答案: