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

Question

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

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

我最初使用 tabs/modules 是为了在选项卡之间保持独立，但收到同事的反馈，如果用户不必重新 select 所有输入，它将帮助用户导航我的应用程序切换选项卡时的选项。

我找到了 of Getting Modules to communicate with each other, (also here)，但还没有找到真正解决这个问题的解决方案。

附加上下文：我的完整应用程序将为 5 个地理位置中的每一个提供不同的选项卡。每个位置都将允许用户 select 完成调查以及调查数据趋势的物种。因此，如果用户（在选项卡 1 上）select 进行了一项调查和一个物种，那么当用户切换到选项卡 2（新地理区域）时，将这些作为第一个选项 selected 会很好。这样，用户可以更快速地比较地理区域之间的相似地块。



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

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

重要的概念是

模块可以return一个值（或多个值）。
主服务器可以监控模块编辑的值return。
模块可以通过对其服务器函数的参数对其他模块中的更改做出反应。（或通过 session$userData：我采用的方法。）

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

因此，依次执行每个步骤...

允许模块服务器return一个值

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

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

这将创建一个 reactive 和 return。请注意，您 return 是 reactive 本身，而不是 reactive 的值。

监控主服务器中模块的 return 值

将 callModule 调用修改为

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

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

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)

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

Can I maintain input defaults across different instances of a Shiny App Module?

r

shiny

shinyapps

shinymodules