Сделайте модуль Shiny реактивным при создании модуля через функцию

Question

Я пытаюсь обобщить модули Shiny так, чтобы через них могли проходить различные функции, но ожидаемое поведение реактивности не работает - кто-то может указать мне правильное направление? У меня есть представление ниже, которое иллюстрирует мою проблему.

Я ожидаю, что динамический выбор view_id изменит значения в функции renderShiny (). Работает при загрузке приложения, но изменения выбора не проходят.

Это как-то связано со средой, в которой создана функция модуля?

library(shiny)

create_shiny_module_funcs <- function(data_f,
                                      model_f,
                                      outputShiny,
                                      renderShiny){

  server_func <- function(input, output, session, view_id, ...){

    gadata <- shiny::reactive({
      # BUG: this view_id is not reactive but I want it to be
      data_f(view_id(), ...)
    })

    model_output <- shiny::reactive({
      shiny::validate(shiny::need(gadata(),
                                  message = "Waiting for data"))
      model_f(gadata(), ...)
    })

    output$ui_out <- renderShiny({
      shiny::validate(shiny::need(model_output(),
                                  message = "Waiting for model output"))
      message("Rendering model output")
      model_output()
    }, ...)

    return(model_output)
  }

  ui_func <- function(id, ...){
    ns <- shiny::NS(id)
    outputShiny(outputId = ns("ui_out"), ...)
  }

  list(
    shiny_module = list(
      server = server_func,
      ui = ui_func
    )
  )

}

# create the shiny module
ff <- create_shiny_module_funcs(
  data_f = function(view_id) mtcars[, view_id],
  model_f = function(x) mean(x),
  outputShiny = shiny::textOutput,
  renderShiny = function(x) shiny::renderText(paste("Mean is: ", x))
)

## ui.R
ui <- fluidPage(title = "module bug Shiny Demo",

                h1("Debugging"),
                selectInput("select", label = "Select", choices = c("mpg","cyl","disp")),
                textOutput("view_id"),
                ff$shiny_module$ui("demo1"),
                br()
)

## server.R
server <- function(input, output, session){

  view_id <- reactive({
    req(input$select)
    input$select
  })

  callModule(ff$shiny_module$server, "demo1", view_id = view_id)

  output$view_id <- renderText(paste("Selected: ", input$select))

}

# run the app
shinyApp(ui, server)

Answer 1

Проблема заключалась в том, что функция renderShiny должна была обернуть другую функцию, которая создает фактический вывод, поэтому ее фактически две отдельные возможности путают меня как одну: renderShiny должна принимать выходные данные другой функции, которая фактически создает вещь для визуализации. Затем работает ниже:

library(shiny)

module_factory <- function(data_f = function(x) mtcars[, x],
                           model_f = function(x) mean(x),
                           output_shiny = shiny::plotOutput,
                           render_shiny = shiny::renderPlot,
                           render_shiny_input = function(x) plot(x),
                           ...){

  ui <- function(id, ...){
    ns <- NS(id)
    output_shiny(ns("ui_out"), ...)
  }

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

    gadata <- shiny::reactive({

      data_f(view_id(), ...)

      })

    model <- shiny::reactive({
      shiny::validate(shiny::need(gadata(),
                                  message = "Waiting for data"))
      model_f(gadata(), ...)
    })

    output$ui_out <- render_shiny({
      shiny::validate(shiny::need(model(),
                                  message = "Waiting for model output"))
      render_shiny_input(gadata())
    })

    return(model)
  }

  list(
    module = list(
      ui = ui,
      server = server
    )
  )
}

made_module <- module_factory()

## ui.R
ui <- fluidPage(title = "module bug Shiny Demo",

                h1("Debugging"),
                selectInput("select", label = "Select", choices = c("mpg","cyl","disp")),
                textOutput("view_id"),
                made_module$module$ui("factory1"),
                br()
)

## server.R
server <- function(input, output, session){

  callModule(made_module$module$server, "factory1", view_id = reactive(input$select))
  output$view_id <- renderText(paste("Selected: ", input$select))

}

# run the app
shinyApp(ui, server)

Answer 2

Я думаю, вы хотите что-то вроде этого.

library(shiny)
library(plyr)
library(dplyr)
library(DT)
library(data.table)

ui <- pageWithSidebar(
  headerPanel = headerPanel('data'),
  sidebarPanel = sidebarPanel(fileInput(
    'mtcars', h4('Uplaodmtcardata in csv format')
  ),
  uiOutput('tabnamesui')),
  mainPanel(uiOutput("tabsets"))
)

server <- function(input, output, session) {
  mtcarsFile <- reactive({
    input$mtcars
  })


  xxmtcars <-
    reactive({
      read.table(
        file = mtcarsFile()$datapath,
        sep = ',',
        header = T,
        stringsAsFactors = T
      )
    })

  tabsnames <- reactive({
    names(xxmtcars())
  })

  output$tabnamesui <- renderUI({
    req(mtcarsFile())
    selectInput(
      'tabnamesui',
      h5('Tab names'),
      choices = as.list(tabsnames()),
      multiple = T
      # selected = SalesGlobalDataFilter1Val()
    )


  })

  tabnamesinput <- reactive({
    input$tabnamesui
  })

  output$tabsets <- renderUI({
    req(mtcarsFile())
    tabs <-
      reactive({
        lapply(tabnamesinput(), function(x)
          tabPanel(title = basename(x)

                   ,fluidRow(splitLayout(cellWidths = c("50%", "50%"),

                                         plotOutput(paste0('plot1',x)),

                                         plotOutput(paste0('plot2',x)
                                         ))),fluidRow(splitLayout(cellWidths = 
                                                                    c("50%", "50%"),

                                                                  plotOutput(paste0('plot3',x)),

                                                                  plotOutput(paste0('plot4',x)
                                                                  ))),
                   dataTableOutput(paste0('table',x))))
      })
    do.call(tabsetPanel, c(tabs()))
  })

  # Save your sub data here
  subsetdata<-reactive({
    list_of_subdata<-lapply(tabnamesinput(), function(x) {
      as.data.table((select(xxmtcars(),x)))
    })
    names(list_of_subdata)<-tabnamesinput()
    return(list_of_subdata)
  })

  observe(
    lapply(tabnamesinput(), function(x) {
      output[[paste0('table',x)]] <- 
        renderDataTable({
          subsetdata()[[x]]
        })}))

  observe(
    lapply(tabnamesinput(), function(x) {
      for(i in paste0("plot",1:4)){
        output[[paste0(i,x)]] <-
          renderPlot({subsetdata()[[x]]%>%plot()#CODE REPEATED
          })
      }
    })
  )

}

runApp(list(ui = ui, server = server))

Источник данных:

https://gist.githubusercontent.com/seankross/a412dfbd88b3db70b74b/raw/5f23f993cd87c283ce766e7ac6b329ee7cc2e1d1/mtcars.csv