模块内部的闪亮模块失去无功值

Question

我正在尝试重用 Mastering Shiny 书中提供的 过滤器模块 代码。它需要一个数据框，为每一列生成一个“select”小部件，并 return 一个 reactive 输出一个布尔向量。该向量可用于根据小部件的 selected 数据范围按行过滤数据帧。

当我直接在 ShinyApp 中重复使用过滤器模块时，这会按预期工作。但是当我尝试从另一个模块内部使用它时，returned reactive 输出 logical(0) 它应该输出一个长度等于输入数据帧行号的向量。

这是一个基于书中代码的最小工作示例。

library(shiny)
library(purrr)

# Filter module from https://mastering-shiny.org/scaling-modules.html#dynamic-ui

#helper functions
make_ui <- function(x, id, var) {
  if (is.numeric(x)) {
    rng <- range(x, na.rm = TRUE)
    sliderInput(id, var, min = rng[1], max = rng[2], value = rng)
  } else if (is.factor(x)) {
    levs <- levels(x)
    selectInput(id, var, choices = levs, selected = levs, multiple = TRUE)
  } else {
    # Not supported
    NULL
  }
}
filter_var <- function(x, val) {
  if (is.numeric(x)) {
    !is.na(x) & x >= val[1] & x <= val[2]
  } else if (is.factor(x)) {
    x %in% val
  } else {
    # No control, so don't filter
    TRUE
  }
}

#Module
filterUI <- function(id) {
  uiOutput(NS(id, "controls"))
}
filterServer <- function(id, df) {
  moduleServer(id, function(input, output, session) {
    vars <- reactive(names(df))
    
    output$controls <- renderUI({
      map(vars(), function(var) make_ui(df[[var]], NS(id, var), var))
    })
    
    reactive({
      each_var <- map(vars(), function(var) filter_var(df[[var]], input[[var]]))
      reduce(each_var, `&`)
    })
  })
}

#App
filterApp <- function() {
  ui <- fluidPage(
    sidebarLayout(
      sidebarPanel(
        textOutput("n"),
        filterUI("filter"),
      ),
      mainPanel(
        verbatimTextOutput("debug"),
        tableOutput("table")    
      )
    )
  )
  server <- function(input, output, session) {
    df <- datasets::ToothGrowth[seq(1,60,5),] #subset rows from ToothGrowth
    filter <- filterServer("filter", df)
    
    output$table <- renderTable(df[filter(), , drop = FALSE])
    output$n <- renderText(paste0(sum(filter()), " rows"))
    output$debug <- renderPrint(filter())
  }
  shinyApp(ui, server)
}

filterApp() #This works !

然后是一个简单的模块，用于从内部测试过滤器：

filterPageUI <- function(id) {
  tagList(
    filterUI(NS(id, "filter"))
  )
}
filterPageServer <- function(id, df) {
  moduleServer(id, function(input, output, session) {
    filterServer("filter", df = df)
  })
}

以及使用这个新模块的 ShinyApp 修改：

filterPageApp <- function() {
  ui <- fluidPage(
    sidebarLayout(
      sidebarPanel(
        textOutput("n"),
        filterPageUI("filterpage"),
      ),
      mainPanel(
        verbatimTextOutput("debug"),
        tableOutput("table")    
      )
    )
  )
  server <- function(input, output, session) {
    #subset rows from ToothGrowth
    df <- datasets::ToothGrowth[seq(1,60,5),]
    filter <- filterPageServer("filterpage", df)
    
    output$table <- renderTable(df[filter(), , drop = FALSE])
    output$n <- renderText(paste0(sum(filter()), " rows"))
    output$debug <- renderPrint(filter())
  }
  shinyApp(ui, server)
}

filterPageApp() #This does not work!

我怀疑问题出在命名空间上，可能在 map/reduce 逻辑内部。但我不能全神贯注。此外，本章的最后一段说这个模块应该可以在其他地方使用而无需修改。

A big advantage of using a module here is that it wraps up a bunch of advanced Shiny programming techniques. You can use the filter module without having to understand the dynamic UI and functional programming techniques that make it work.

如有任何建议，我们将不胜感激。提前致谢！

Answer 1

在您的 filterServer 函数中，您必须使用 session$ns("var") 而不是 NS(id, "var")。前者将包括封闭的命名空间，而后者将仅包括当前命名空间。我添加了两条消息，它们将在控制台中显示我的意思。

filterServer <- function(id, df) {
  moduleServer(id, function(input, output, session) {
    message("session namespace: ", session$ns("test"))
    message("raw namespace: ", NS(id, "test"))
    vars <- reactive(names(df))
    
    output$controls <- renderUI({
      map(vars(), function(var) make_ui(df[[var]], session$ns(var), var))
    })
    
    reactive({
      each_var <- map(vars(), function(var) filter_var(df[[var]], input[[var]]))
      reduce(each_var, `&`)
    })
  })
}

模块内部的闪亮模块失去无功值

shiny module inside module loosing reactive value

r

shiny

purrr