Доступ к фреймам данных, созданным с помощью модулей, с их именами и сохранение их в списке

Question

Я создаю приложение с модулями на основе этого ответа . По сути, это приложение, в котором можно создавать идентичные вкладки с разными именами ввода, просто щелкнув вкладку с именем More.

Теперь я хотел бы дать пользователю возможность объединить некоторые (или все) созданные таблицы. Для этого есть (постоянная) вкладка с именем Merge, в которой есть checkBoxInput. Когда никакая вкладка не создана, эта checkBoxInput пуста (так как нет вкладки и, следовательно, нет таблицы для выбора). Когда создается одна вкладка и, следовательно, одна таблица, я бы хотел, чтобы checkBoxInput был обновлен, чтобы отобразить поле и имя, соответствующее этой таблице. Например, если я создаю 3 вкладки, в checkBoxInput должно быть 3 поля.

До сих пор моя идея заключалась в том, чтобы хранить таблицы, созданные в списке, и обновлять checkBoxInput содержимым этот список каждый раз, когда создается вкладка и таблица. Однако я не знаю, как получить имя таблиц, созданных в модуле. Поскольку таблицы названы x в модуле moduleTable, я подумал, что мог бы просто использовать x, но это дает мне следующую ошибку:

Предупреждение: Ошибка в наблюдаемомEventHandler: object ' x 'not found

Ниже приведен воспроизводимый пример:

library(shiny)
library(shinyWidgets)
library(dplyr)

addTab <- function(id) {
  ns <- NS(id)
  tagList(
    selectInput(ns("select"),
                "Choose", 
                choices = colnames(mtcars)),
    tableOutput(ns("table"))
  )
}

moduleTable <- function(input, output, session){
  x <- reactive(select(mtcars, input$select))
  output$table <- renderTable({
    x()
  })
}


ui <- navbarPage(position = "static-top",
                 title = "foo",
                 id = "tabs",
                 tabPanel(title = "Merge",
                          fluidRow(
                            checkboxGroupInput("to_merge",
                                               label = "Tables to merge",
                                               choices = NULL)
                          )),
                 tabPanel(title = "More",
                          icon = icon("plus"),
                          fluidRow()
                          )
)

server <- function(input, output, session) {

  count <- reactiveValues(val=0)

  dfs <- list()

  observeEvent(input$tabs, {
    if (input$tabs == "More"){
      count$val <- count$val+1
      name <- paste0("Name ", count$val)
      insertTab(inputId = "tabs",
                tabPanel(title = name,
                         addTab(paste0("select", count$val))
                ), 
                target = "More", 
                position = "before",
                select = TRUE)

      callModule(moduleTable, paste0("select", count$val))

      dfs[[count$val]] <- paste0("mtcars$select", count$val)
      # UNCOMMENT THE LINE BELOW AND COMMENT THE LINE ABOVE TO SEE THE PROBLEM
      # tables[[count$val]] <- x

      names(dfs[count$val]) <- paste0("df", count$val)

      updateCheckboxGroupInput(session = session,
                               inputId = "to_merge",
                               choices = names(dfs))
    }
  })  
}

shinyApp(ui = ui, server = server)

Как получить имена созданных кадров данных и сохранить их в списке реагирования?

Answer 1

Вы можете попробовать следующий код, чтобы вернуть реактивное выражение и присоединиться к таблице.

library(shiny)
library(shinyWidgets)
library(tidyverse)

addTab <- function(id) {
  ns <- NS(id)
  tagList(
    selectInput(ns("select"),
                "Choose", 
                choices = colnames(mtcars[, -1])),
    tableOutput(ns("table"))
  )
}

moduleTable <- function(input, output, session){
  x <- reactive(select(mtcars, c(mpg, input$select)))
  output$table <- renderTable({
    x()
  })
  return(x)
}


ui <- navbarPage(position = "static-top",
                 title = "foo",
                 id = "tabs",
                 tabPanel(title = "Merge",
                          fluidRow(
                            checkboxGroupInput("to_merge",
                                               label = "Tables to merge",
                                               choices = NULL),
                            tableOutput("table")
                          )),
                 tabPanel(title = "More",
                          icon = icon("plus"),
                          fluidRow()
                 )
)

server <- function(input, output, session) {

  count <- reactiveValues(val=0)
  tables <- reactiveValues()

  dfs <- list()

  observeEvent(input$tabs, {
    if (input$tabs == "More"){
      count$val <- count$val+1
      name <- paste0("Name ", count$val)
      insertTab(inputId = "tabs",
                tabPanel(title = name,
                         addTab(paste0("select", count$val))
                ), 
                target = "More", 
                position = "before",
                select = TRUE)

      x <- callModule(moduleTable, paste0("select", count$val))
      tables[[name]] <- x
    }
  })

  observe({
    updateCheckboxGroupInput(session = session,
                             inputId = "to_merge",
                             choices = names(tables),
                             selected = input$to_merge)
  })

  observe({
    req(input$to_merge)
    output$table <- renderTable({
      if(!is.null(input$to_merge)) {
        tabs <- map(input$to_merge, ~{tables[[.x]]()})
        reduce(tabs, full_join)
      }
    })
  })
}

shinyApp(ui = ui, server = server)

Answer 2

ОБНОВЛЕНИЕ (немного ближе, но пока нет):

Я знаю, что модули могут возвращать данные (как reactiveValues). Поэтому моя задача сейчас - вернуть данные в вашем x(). С некоторыми случайными нереактивными значениями это работает в том смысле, что я могу собрать (добавить) выходные данные вызова модуля в переменную и затем показать эти значения в виде строки, например. Вот где я:

library(shiny)
library(shinyWidgets)
library(dplyr)

addTab <- function(id) {
    ns <- NS(id)
    tagList(
        selectInput(ns("select"),
                    "Choose", 
                    choices = colnames(mtcars)),
        tableOutput(ns("table"))
    )
}

moduleTable <- function(input, output, session){
    x <- reactive(select(mtcars, input$select))
    output$table <- renderTable({
        x()
    })

    table_list <- reactiveValues()

    table_list$test <- sample(letters, 1)
    table_list$first_value <- x()[1,1]

    return(table_list)
}

ui <- navbarPage(position = "static-top",
                 title = "foo",
                 id = "tabs",
                 tabPanel(title = "Merge",
                    fluidRow(
                            checkboxGroupInput("to_merge",
                                               label = "Tables to merge",
                                               choices = NULL),
                            textOutput("string"),
                            textOutput("first_value")
                        )),
                    tabPanel(title = "More",
                             icon = icon("plus"),
                             fluidRow()
                    )
)

server <- function(input, output, session) {

    vals <- reactiveValues(val = 0, name = "", string_output = NULL, first_value = NULL)

    observeEvent(input$tabs, {
        if (input$tabs == "More"){
            vals$val <- vals$val+1
            name <- paste0("Name ", vals$val)
            insertTab(inputId = "tabs",
                                tabPanel(title = name,
                                         addTab(paste0("select", vals$val))
                                ), 
                                target = "More", 
                                position = "before",
                                select = TRUE)

            m_output <- callModule(moduleTable, paste0("select", vals$val))

            vals$string_output <- c(vals$string_output, m_output$test)
            vals$first_value <- c(vals$first_value, m_output$first_value)

            vals$name[vals$val] <- paste0("mtcars$select", vals$val, "_", m_output$test)

            updateCheckboxGroupInput(session = session,
                                     inputId = "to_merge",
                                     choices = vals$name)

            output$string <- renderText({
                req(input$tabs)
                paste(vals$string_output, collapse = ", ")  
            })

            output$first_value <- renderText({
                req(input$tabs)
                paste(vals$first_value, collapse = ", ")        # This doesn't work as expected 
            })

            }
    })  
    }

shinyApp(ui = ui, server = server)

Как насчет этого?

library(shiny)
library(shinyWidgets)
library(dplyr)

addTab <- function(id) {
    ns <- NS(id)
    tagList(
        selectInput(ns("select"),
                                "Choose", 
                                choices = colnames(mtcars)),
        tableOutput(ns("table"))
    )
}

moduleTable <- function(input, output, session){
    x <- reactive(select(mtcars, input$select))
    output$table <- renderTable({
        x()
    })
}

ui <- navbarPage(position = "static-top",
                                 title = "foo",
                                 id = "tabs",
                                 tabPanel(title = "Merge",
                                                 fluidRow(
                                                    checkboxGroupInput("to_merge",
                                                                                         label = "Tables to merge",
                                                                                         choices = NULL)
                                                 )),
                                 tabPanel(title = "More",
                                                 icon = icon("plus"),
                                                 fluidRow()
                                 )
)

server <- function(input, output, session) {

    vals <- reactiveValues(val=0, name = "")
    dfs <- list()

    observeEvent(input$tabs, {
        if (input$tabs == "More"){
            vals$val <- vals$val+1
            name <- paste0("Name ", vals$val)
            insertTab(inputId = "tabs",
                                tabPanel(title = name,
                                                 addTab(paste0("select", vals$val))
                                ), 
                                target = "More", 
                                position = "before",
                                select = TRUE)

            callModule(moduleTable, paste0("select", vals$val))

            vals$name[vals$val] <- paste0("mtcars$select", vals$val)

            print(vals$name)
            updateCheckboxGroupInput(session = session,
                                     inputId = "to_merge",
                                     choices = vals$name)
        }
    })  
}

shinyApp(ui = ui, server = server)