如何使用闪亮的模块重复更新相同的 table

Question

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

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

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

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

最后，如果我将下拉列表 1 更改为 'sandwich'，然后将下拉列表 2 更改为 'a'，然后单击更新 table，我希望 table 看起来像这样：

下面是一个最小示例的代码，在 TabButtonServer 模块中，您将看到我为使它起作用所做的最佳尝试，但它没有起作用。如上所述，问题的症结在于我不知道如何在 table 更新时存储它，以便以后可以再次引用它。我非常感谢有人可以提供的任何帮助。


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

Answer 1

一种方法是使用 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)

如何使用闪亮的模块重复更新相同的 table

How to repeatedly update the same table using shiny modules

r

shiny

shinymodules