Question

我在下面创建了一个示例应用来说明我遇到的问题。我在Shiny中有一个使用多层模块的应用程序。我非常熟悉使用模块并从模块本身返回无功值。但是当我需要使用lapply来创建多个模块调用（在这种情况下，slider_menu_item_shiny函数来创建多个滑块）时，每个都返回用户在滑块中设置的无功值，我不知道如何动态捕获所有输出反应变量为一个反应向量。

现在我有2个硬编码的滑块，这个简单的应用程序工作。但是我希望能够在第一个输入中键入任意值，让应用程序使用lapply语句创建该数量的滑块模块（对于callModule（slider_menu_item_shiny）调用也是如此）然后让slider_value_vector包含该长度的向量包含所有滑块值。

我觉得我错过了使这项工作的根本伎俩。我非常感谢学习经历和所有帮助。

ui.R代码

library(shiny)
library(shinydashboard)
library(DT)

#### MODULE CODE ####
source("modules.R")

# define header
header <- dashboardHeader(
  title = "Test"
)

# define body
body <- dashboardBody(

  tabItems(
    body_set_shinyUI(id = "body_test_mod", tab_name = "body_test_mod")
  )
)

# define sidebar
sidebar <- dashboardSidebar(
    sidebarMenu(id = "dashboard_menu",
      menuItem("Test Body", tabName = "body_test_mod")
    )
)

dashboardPage(skin = "blue",
              header,
              sidebar,
              body
)

server.R code

library(shiny)
library(shinydashboard)
library(DT)

#### MODULE CODE ####
source("modules.R")

#### SERVER CODE ####
function(input, output, session) {
  callModule(body_set_shiny, id = "body_test_mod")
}

modules.R code

### body_set_shiny
body_set_shinyUI <- function(id, tab_name) {
  ns <- NS(id)


  tabItem(tabName = tab_name,
          fluidRow(
            column(12,
                   inner_body_test_menu_shinyUI(ns("inner_body_test_mod"))
            )
          )
  )
}
body_set_shiny <- function(input, output, session) {
  callModule(inner_body_test_menu_shiny, id = "inner_body_test_mod")
}

### inner_body_test_menu_shiny
inner_body_test_menu_shinyUI <- function(id) {
  ns <- NS(id)

  fluidRow(
    column(12,
           box(title = "Test Inner Menu",
               width = 12,
               fluidRow(
                 column(12,
                        wellPanel(
                          uiOutput(ns("inner_number_menu")),
                          uiOutput(ns("inner_sliders_menu")),
                          uiOutput(ns("inner_text_output"))
                        )
                 )
               )
           )
    )
  )
}

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

  output$inner_number_menu <- renderUI({
    ns <- session$ns
    textInput(ns("inner_number_value"), label = "Enter Number of Sliders", value = "2")
  })

  slider_length <- reactive({
    if (is.null(input$inner_number_value))
      return()

    as.numeric(input$inner_number_value)
  })

  output$inner_sliders_menu <- renderUI({
    if (is.null(slider_length()))
      return()

    ns <- session$ns

    lapply((1:slider_length()), function(m) {  

      slider_menu_item_shinyUI(ns(paste("slider_menu_item_", m, sep = "")))
    })

  })

  output$inner_text_output <- renderText({ 
    if (is.null(slider_value_vector()))
      return()

    paste("You have entered", slider_value_vector())
  })

  slider_value_vector <- reactive({
    if (is.null(slider_length()))
      return()
    c(as.numeric(slider_v1()[[1]]),as.numeric(slider_v2()[[1]]))
  })


  slider_v1 <- callModule(slider_menu_item_shiny, paste("slider_menu_item_", 1, sep = ""))
  slider_v2 <- callModule(slider_menu_item_shiny, paste("slider_menu_item_", 2, sep = ""))

}


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

  uiOutput(ns('sider_output_menu'))
}

slider_menu_item_shiny <- function(input, output, session, slider_value = 0, slider_name = "No Name Found") {

  output$sider_output_menu <- renderUI({
    ns <- session$ns

    uiOutput(ns("slider_item_menu"))
  })

  output$slider_item_menu <- renderUI({
    ns <- session$ns

    sliderInput(ns("slider_item"), label = "Slider Example", min = -1, max = 1, value = 0.5, step = 0.01)
  })

  return(reactive(list(input$slider_item)))
}

lapply模块并利用闪亮模块的无功返回

0 个答案: