1

我有一个使用模块的闪亮应用程序。在这个应用程序中，有几个下拉菜单需要在表格中填充选项。第一个下拉列表与第二个下拉列表相关，并提供行过滤器以更改表第二列中第二个下拉列表的值，但是第一个下拉列表中的值不应更改表第一列中的值。

该表应首先自动填充下拉列表的默认值（这些值各不相同，因此不能硬编码）。当应用程序的用户希望在表格中发生更改时，他们将查看选项并单击更新按钮。从这个可重现的例子中看不出来，但在更大的应用程序中，用户需要从他们上次更新的数据中不断更新表，而不仅仅是发送一个完整的数据表来重新填充整个数据。我知道如何使用下拉列表中的值来填充表格一次，但我无法理解如何将表格（或任何对象）存储在某处以便可以连续访问和更新。

如果描述不完全清楚，我希望在初始化时出现这样的表：

默认表

然后，如果我将下拉列表 2 更改为“b”并单击更新表，我希望它看起来像这样：

第一次更新

最后，如果我将下拉菜单 1 更改为“三明治”，然后将下拉菜单 2 更改为“a”并单击更新表，我希望该表如下所示：

最后更新

下面是一个最小示例的代码，在TabButtonServer模块中你会看到我最好的尝试让它工作，但它没有。如上所述，问题的症结是我不知道在更新表时应该如何存储表，以便以后可以再次引用它。我非常感谢有人可以提供的任何帮助。


## first drop down
ChooseUI1 <- function(id) {
  
  selectInput(NS(id, "choice1"),
              label=NULL,
              choices=c("foo", "bar", "ham", "sandwich"))
  
}

ChooseServer1 <- function(id) {

  moduleServer(id, function(input, output, session) {
    
    reactive({
      input$choice1
    })
    
  })
}


## second drop down
ChooseUI2 <- function(id) {
  
  selectInput(NS(id, "choice2"),
              label=NULL,
              choices=c("a", "b", "c", "d"))
  
}

ChooseServer2 <- function(id) {
  
  moduleServer(id, function(input, output, session) {
    
    reactive({
      input$choice2
    })
    
  })
}


## button to change table
TabButtonUi <- function(id){
  
  actionButton(NS(id, "tab_change"),
               label="Update Table")
  
}

TabButtonServer <- function(id, c1, c2) {
  stopifnot(is.reactive(c1))
  stopifnot(is.reactive(c2))
  
  moduleServer(id, function(input, output, session) {
    
    start_table <- reactive({
      cbind.data.frame(col1=c("foo", "bar", "ham", "sandwich"),
                       col2=c("a", "b", "c", "d"),
                       stringsAsFactors=FALSE)
    })
    
    new_table <- data.frame(col1=character(), col2=character())
    output_change <- eventReactive(input$tab_change, {
      
      if(input$tab_change == 0) {
        new_table <- start_table()
      } else {
        new_table[new_table[ , "col1"] == c1(), "col2"] <<- c2()
      }
      new_table
      
    }, ignoreNULL=FALSE)
    
    
    reactive({
      output_change()
    })
    
  })
}



## view table
viewTabUi <- function(id){
  tableOutput(NS(id, "view_tab"))
}

viewTabServer <- function(id, tab) {
  stopifnot(is.reactive(tab))
  
  moduleServer(id, function(input, output, session) {
    
    output$view_tab <- renderTable(tab())
    
  })
}


## the app
ui <- navbarPage(
  title="test",
  tabPanel(title="first page",
           sidebarLayout(
             sidebarPanel(
               ChooseUI1("c1"),
               ChooseUI2("c2"),
               TabButtonUi("tab"),
               viewTabUi("view_tab")
             ),
             mainPanel(
               
             )
           )
  )
)


server <- function(input, output, session) {
  c1 <- ChooseServer1("c1")
  c2 <- ChooseServer2("c2")
  tab <- TabButtonServer("tab", c1, c2)
  viewTabServer("view_tab", tab)
}


shinyApp(ui, server)
4

1 回答 1

2

一种方法是使用reactiveValues()如下所示的对象。

## first drop down
ChooseUI1 <- function(id) {
  
  selectInput(NS(id, "choice1"),
              label=NULL,
              choices=c("foo", "bar", "ham", "sandwich"))
  
}

ChooseServer1 <- function(id) {
  
  moduleServer(id, function(input, output, session) {
    
    reactive({
      input$choice1
    })
    
  })
}


## second drop down
ChooseUI2 <- function(id) {
  
  selectInput(NS(id, "choice2"),
              label=NULL,
              choices=c("a", "b", "c", "d"))
  
}

ChooseServer2 <- function(id) {
  
  moduleServer(id, function(input, output, session) {
    
    reactive({
      input$choice2
    })
    
  })
}


## button to change table
TabButtonUi <- function(id){
  
  actionButton(NS(id, "tab_change"),
               label="Update Table")
  
}

TabButtonServer <- function(id, c1, c2) {
  stopifnot(is.reactive(c1))
  stopifnot(is.reactive(c2))
  
  moduleServer(id, function(input, output, session) {
    
    start_table <-  cbind.data.frame(col1=c("foo", "bar", "ham", "sandwich"),
                                     col2=c("a", "b", "c", "d"),
                                     stringsAsFactors=FALSE)
    
    rv <- reactiveValues(df=NULL)
    
    observeEvent(input$tab_change, {
      
      if(input$tab_change == 0) {
        rv$df <- start_table
      } else {
        rv$df[rv$df$col1 == c1(), "col2"] <<- c2()
      }
      
    }, ignoreNULL=FALSE)
    
    reactive({
      rv$df
    })
    
  })
}


## view table
viewTabUi <- function(id){
  tableOutput(NS(id, "view_tab"))
}

viewTabServer <- function(id, tab) {
  stopifnot(is.reactive(tab))
  
  moduleServer(id, function(input, output, session) {
    
    output$view_tab <- renderTable(tab())
    
  })
}


## the app
ui <- navbarPage(
  title="test",
  tabPanel(title="first page",
           sidebarLayout(
             sidebarPanel(
               ChooseUI1("c1"),
               ChooseUI2("c2"),
               TabButtonUi("tab"),
               viewTabUi("view_tab")
             ),
             mainPanel(
               
             )
           )
  )
)

server <- function(input, output, session) {
  c1 <- ChooseServer1("c1")
  c2 <- ChooseServer2("c2")
  tab <- TabButtonServer("tab", c1, c2)
  viewTabServer("view_tab", tab)
}

shinyApp(ui, server)

替代答案：为了利用模块编程，您可以selectInput多次使用一个模块，如下所示

####  drop down
ChooseUI1 <- function(id) {

  selectInput(NS(id, "choice1"), label=NULL, choices=NULL)

}

ChooseServer1 <- function(id,df_col) {

  moduleServer(id, function(input, output, session) {
    updateSelectInput(session, "choice1", choices= unique(df_col))
    
    reactive({
      input$choice1
    })

  })
}


## button to change table
TabButtonUi <- function(id){

  actionButton(NS(id, "tab_change"), label="Update Table")

}

TabButtonServer <- function(id, c1, c2, start_table) {
  stopifnot(is.reactive(c1))
  stopifnot(is.reactive(c2))

  moduleServer(id, function(input, output, session) {
    
    rv <- reactiveValues(df=NULL)

    observeEvent(input$tab_change, {

      if(input$tab_change == 0) {
        rv$df <- start_table
      } else {
        rv$df[rv$df$col1 == c1(), "col2"] <<- c2()
      }
      
    }, ignoreNULL=FALSE)
    
    reactive({ rv$df })

  })
}


## view table
viewTabUi <- function(id){
  tableOutput(NS(id, "view_tab"))
}

viewTabServer <- function(id, tab) {
  stopifnot(is.reactive(tab))

  moduleServer(id, function(input, output, session) {

    output$view_tab <- renderTable(tab())

  })
}


## the app
ui <- navbarPage(
  title="test",
  tabPanel(title="first page",
           sidebarLayout(
             sidebarPanel(
               ChooseUI1("c1"),
               ChooseUI1("c2"),
               TabButtonUi("tab"),
               viewTabUi("view_tab")
             ),
             mainPanel()
           )
  )
)

server <- function(input, output, session) {
  df <-  cbind.data.frame(col1=c("foo", "bar", "ham", "sandwich"),
                          col2=c("a", "b", "c", "d"),
                          stringsAsFactors=FALSE)
  cc1 <- ChooseServer1("c1",df$col1)
  cc2 <- ChooseServer1("c2",df$col2)
  tab <- TabButtonServer("tab", cc1, cc2, df)
  viewTabServer("view_tab", tab)
}

shinyApp(ui, server)
于 2021-11-30T03:12:23.233 回答