0

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

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

我最初使用的选项卡/模块打算在选项卡之间具有独立性，但收到一位同事的反馈，如果他们在切换选项卡时不必重新选择所有输入选项，它将帮助用户导航我的应用程序。

我找到了一些让模块相互通信的示例， （也在这里），但还没有找到真正解决这个问题的解决方案。

附加背景：我的完整应用程序将为 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)
4

1 回答 1

2

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

重要的概念是

  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")

我在这里所做的只是将模块的返回值分配给主服务器函数中的局部变量。他们是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()})

您可以print在每个内部调用observeEvent以查看发生了什么。我在测试时这样做了。我认为这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)
于 2020-07-31T08:22:56.667 回答