我可以在 Shiny App Module 的不同实例中维护输入默认值吗？

Question

我想看看是否可以从 Shiny App 模块的一个实例中获取输入，并将它们用作不同选项卡上同一模块的单独实例的默认输入。我正在努力以正确的方式提出这个问题，但我试图在下面创建一个可重现的示例。我有一个闪亮的仪表板，有大约 5 个选项卡，每个选项卡都调用相同的绘图模块。

例如，在下面的代码中，我创建了一个可生成绘图的简化仪表板。如果有人点击“标签页 1”并将绘图颜色更改为“深粉色”，现在是否可以在用户点击“标签页 2”时将该输入设置为默认颜色选项？或者用户是否总是必须重新选择颜色输入？

我最初使用选项卡/模块是为了让选项卡之间保持独立，但收到一位同事的反馈，如果用户在切换选项卡时不必重新选择所有输入选项，这将有助于用户浏览我的应用程序。

我发现Getting Modules 中的Some Examples 可以相互通信，(also here)，但还没有找到真正解决这个问题的解决方案。

其他背景：我的完整应用将为 5 个地理位置中的每一个提供不同的选项卡。每个位置都将允许用户选择已完成的调查以及调查数据趋势的物种。因此，如果用户（在选项卡 1 上）选择了一项调查和一个物种，那么当用户切换到选项卡 2（新地理区域）时，最好将这些选项作为第一个选项。通过这种方式，用户可以更快地比较地理区域之间的相似地块。

library(shiny)
library(shinydashboard)



# Module UI for simple plot

dataPlotUI <- function(id) {
  ns <- NS(id) # create namespace for entered ID


  fluidRow(
    box(
      plotOutput(ns("plot.1"), height = 400)
    ),

    box(
      selectInput(
        ns("color.choice"), "Color:",
        c("darkcyan", "darkolivegreen", "deeppink", "lightsalmon2", "slateblue2", "springgreen3")
      ),

      sliderInput(ns("range"), label = "Range", min = 10, max = 100, value = 50)
    ) # end box
  )
}


########################################
########################################
# Module for Server

#
serverModule <- function(input, output, session, site) {
  output$plot.1 <- renderPlot({
    x <- seq(1, input$range, 1) # use slider to set max of x
    y <- x + rnorm(length(x), 0, 3)


    par(mai = c(.6, .6, .1, .1), las = 1, bty = "l")
    plot(y ~ x, pch = 20, col = input$color.choice)
  })
}


########################################
########################################

# UI


ui <- dashboardPage(

  # # Dashboard Header
  dashboardHeader(title = "Menu"),
  #

  dashboardSidebar(
    sidebarMenu(
      id = "sidebar",
      # Icons can be found: https://fontawesome.com/icons?d=gallery&m=free
      menuItem("Tab Page 1", tabName = "tabA"),
      menuItem("Tab Page 2", tabName = "tabB"),
      menuItem("Tab Page 3", tabName = "tabC")
    )
  ), # End Dashboard Sidebar


  # Body of the dashboard
  dashboardBody(

    # Start with overall tabItems
    tabItems(
      tabItem(
        tabName = "tabA",
        dataPlotUI("tab_one")
      ),
      #
      tabItem(
        tabName = "tabB",
        dataPlotUI("tab_two")
      ),

      tabItem(
        tabName = "tabC",
        dataPlotUI("tab_three")
      )
    )
  ) # end dashboard body
)

#######################################
#######################################


# Server
# Call modules


server <- function(input, output, session) {
  callModule(serverModule, "tab_one")
  callModule(serverModule, "tab_two")
  callModule(serverModule, "tab_three")
}




shinyApp(ui = ui, server = server)

Answer 1

是的，这是可能的。这是一种方法。

重要的概念是

1. 模块可以返回一个（或多个）值。
2. 主服务器可以监控模块返回的值。
3. 模块可以通过其服务器函数的参数来响应其他模块的变化。 （或通过session$userData：我采用的方法。）

我想你知道最后一个，因为你在模块服务器中有一个 site 参数，尽管你似乎没有使用它。

所以，依次采取每一步...

允许模块服务器返回值

在模块服务器函数的末尾添加以下行

rv <- reactive({input$color.choice})
return(rv)

这会创建一个reactive 并返回它。请注意，您返回的是 reactive 本身，而不是 reactive 的值。

在主服务器中监控模块的返回值

将callModule 调用修改为

tab1 <- callModule(serverModule, "tab_one")
tab2 <- callModule(serverModule, "tab_two")
tab3 <- callModule(serverModule, "tab_three")

我在这里所做的只是将模块的返回值分配给主服务器函数中的局部变量。他们是reactives，所以我们可以监控他们。将以下行添加到主服务器函数：

session$userData$settings <- reactiveValues(chosenColour=NA)
observeEvent(tab1(), {session$userData$settings$chosenColour <- tab1()})
observeEvent(tab2(), {session$userData$settings$chosenColour <- tab2()})
observeEvent(tab3(), {session$userData$settings$chosenColour <- tab3()})

您可以在每个observeEvent 中放置print 调用，以查看发生了什么。我在测试时这样做了。我认为session$userData 是闪亮的一个未被充分利用的功能。不出所料，它是用户可写的session 对象的一部分。主服务器函数和所有模块服务器函数共享同一个session$userData 对象，因此这是一种在模块之间传递信息的简洁方式。

我假设您要做的不仅仅是改变现实世界案例中点的颜色，所以我创建了一个settings 对象。我已将其设置为反应式，以便模块可以对其中的更改做出反应。

让模块对变化做出反应

将以下代码添加到模块服务器函数中

  observeEvent(
    session$userData$settings$chosenColour, 
    {
      if (!is.na(session$userData$settings$chosenColour)) 
        updateSelectInput(
          session, 
          "color.choice", 
          selected=session$userData$settings$chosenColour
        )
    }
  )

[再次，将print 调用放入observeEvent 以检查发生了什么。]

就是这样。

顺便说一句，最好总是添加

ns <- session$ns

作为模块服务器函数的第一行。你现在不需要它，但很可能你会。我花了很多时间追查一个由于“不需要”session$ns 而导致的错误。现在我只是默认这样做以节省痛苦。

这是您修改后的 MWE 的完整列表。

library(shiny)
library(shinydashboard)

dataPlotUI <- function(id) {
  ns <- NS(id) # create namespace for entered ID
  fluidRow(
    box(plotOutput(ns("plot.1"), height = 400)),
    box(
      selectInput(
        ns("color.choice"), "Color:",
        c("darkcyan", "darkolivegreen", "deeppink", "lightsalmon2", "slateblue2", "springgreen3")
      ),
      sliderInput(ns("range"), label = "Range", min = 10, max = 100, value = 50)
    ) # end box
  )
}

# Module for Server
serverModule <- function(input, output, session, site) {
  ns <- session$ns
  
  output$plot.1 <- renderPlot({
    x <- seq(1, input$range, 1) # use slider to set max of x
    y <- x + rnorm(length(x), 0, 3)
    
    par(mai = c(.6, .6, .1, .1), las = 1, bty = "l")
    plot(y ~ x, pch = 20, col = input$color.choice)
  })
  
  observeEvent(session$userData$settings$chosenColour, {
    if (!is.na(session$userData$settings$chosenColour)) updateSelectInput(session, "color.choice", selected=session$userData$settings$chosenColour)
  })
  
  rv <- reactive({input$color.choice})
  return(rv)
}

# UI
ui <- dashboardPage(
  dashboardHeader(title = "Menu"),
  dashboardSidebar(
    sidebarMenu(
      id = "sidebar",
      # Icons can be found: https://fontawesome.com/icons?d=gallery&m=free
      menuItem("Tab Page 1", tabName = "tabA"),
      menuItem("Tab Page 2", tabName = "tabB"),
      menuItem("Tab Page 3", tabName = "tabC")
    )
  ), # End Dashboard Sidebar
  dashboardBody(
    # Start with overall tabItems
    tabItems(
      tabItem(
        tabName = "tabA",
        dataPlotUI("tab_one")
      ),
      #
      tabItem(
        tabName = "tabB",
        dataPlotUI("tab_two")
      ),
      
      tabItem(
        tabName = "tabC",
        dataPlotUI("tab_three")
      )
    )
  ) # end dashboard body
)

# Server
server <- function(input, output, session) {
  session$userData$settings <- reactiveValues(chosenColour=NA)
  tab1 <- callModule(serverModule, "tab_one")
  tab2 <- callModule(serverModule, "tab_two")
  tab3 <- callModule(serverModule, "tab_three")
  # Module observers
  observeEvent(tab1(), {session$userData$settings$chosenColour <- tab1()})
  observeEvent(tab2(), {session$userData$settings$chosenColour <- tab2()})
  observeEvent(tab3(), {session$userData$settings$chosenColour <- tab3()})
}

shinyApp(ui = ui, server = server)