使用 {golem} 闪亮的相互依赖的过滤器模块化 reactiveUI

Question

以下闪亮的应用程序运行良好但有一个问题：由于动态过滤，它显示错误或警告。

library(shiny)
ui <- dashboardPage(
   dashboardHeader(),
   dashboardSidebar(
       titlePanel(
           div(style="line-height: 100%",
               align = 'center',
               span("Awesome reprex"),
               hr()
               )
           ),
       sidebarMenu(
           menuItem("Home", tabName = "Home", icon = icon("fas fa-home")),
           menuItem("Main section", tabName = "Main", icon = icon("far fa-chart-bar"))
       )
   ),
   dashboardBody(
       
       tabItems(tabItem(tabName = "Home"),
           
           tabItem(tabName = "Main",
                   fluidRow(
                   ),

                   fluidRow(),
                   hr(),

                   fluidRow(style = 'background: white;',
                            div(
                                box(
                                    title= "Much filters",
                                    style = 'height:420px; background: gainsboro; margin-top: 5vw;',
                                    width=3,
                                    solidHeader = TRUE,
                                    uiOutput("continent"),
                                    uiOutput("country")
                                ),
                                tabBox(
                                    width = 9,
                                    title = "Results",
                                    id = "tabset1",
                                    tabPanel(style = 'overflow-y:scroll;height:420px;',"Awesome results !",
                                             style="zoom: 90%;",
                                             DT::dataTableOutput("awesometable")
                                    )
                                )
                            )
                   )
           )
           )
       )
   )



library(data.table)
library(shiny)
library(gapminder

server <- function(input, output, session) {
   
   df <- gapminder::gapminder
   
   output$continent = renderUI({
       selectizeInput(inputId = "continent",
                      label = "Continent :",
                      choices = unique(df[,"continent"]),
                      selected = unique(df[,"continent"])[1])
   })
   # #
   datasub <- reactive({
       df[df$continent == input$continent,]
   })

   output$country = renderUI({
       selectizeInput(inputId = "country",
                      label = "Country :",
                      choices = unique(datasub()[,"country"])
       )
   })
   # 
   datasub2 <- reactive({
       datasub()[datasub()$country == input$country, ]
   })
   
   output$awesometable <- DT::renderDataTable({
       
       datasub2()
   })
}


shinyApp(ui, server)

第一部分问题：一旦我包含了我在此处找到的过滤方法，错误就开始显示：

在尝试了不同的方法之后，这是一种非常接近我正在寻找的方法。

但是，应用加载后，控制台中会显示：

逻辑下标必须匹配索引输入的大小。输入的大小为 392，但下标 datasub2()$country== input$country 的大小为 0.

第二部分问题：该应用程序是使用 {golem} 包开发的，这在构建可扩展和可维护的闪亮基础架构时非常有用。但是，我没有得到我所期望的（而且我得到了错误）。我该如何解决？我如何“模块化”我找到的解决方法来创建相互依赖的过滤器？

我一直在尝试类似的方法：

#' awesome_app_ui UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd 
#'
#' @import DT
#' @import plotly
#' @import htmltools
#' @import shinydashboard
#' @importFrom reactable JS
#' @importFrom shiny NS tagList 
mod_chiffres_cles_ts_ui <- function(id){
  
  ns <- NS(id)
  
  df <- gapminder::gapminder

tabBox(width = 9,title = "Results",d = "tabset1",
tabPanel(style = 'overflow-y:scroll;height:420px;',"Awesome results !",
style="zoom: 90%;",DT::dataTableOutput("awesometable"))
  
  
}

#' awesome_app Server Functions
#'
#' @noRd 
mod_chiffres_cles_ts_server <- function(id){
  moduleServer( id, function(input, output, session){
    ns <- session$ns

df <- gapminder::gapminder

   output$continent = renderUI({
       selectizeInput(inputId = "continent",
                      label = "Continent :",
                      choices = unique(df[,"continent"]),
                      selected = unique(df[,"continent"])[1])
   })
   # #
   datasub <- reactive({
       df[df$continent == input$continent,]
   })

   output$country = renderUI({
       selectizeInput(inputId = "country",
                      label = "Country :",
                      choices = unique(datasub()[,"country"])
       )
   })
   # 
   datasub2 <- reactive({
       datasub()[datasub()$country == input$country, ]
   })

   output$awesometable <- DT::renderDataTable({

       datasub2()
   })
}

谢谢！

Answer 1

一旦你适当地使用 req()，你的程序就可以正常工作。

library(shiny)
library(data.table)
library(shiny)
library(gapminder)

ui <- dashboardPage(
  dashboardHeader(),
  dashboardSidebar(
    titlePanel(
      div(style="line-height: 100%",
          align = 'center',
          span("Awesome reprex"),
          hr()
      )
    ),
    sidebarMenu(
      menuItem("Home", tabName = "Home", icon = icon("fas fa-home")),
      menuItem("Main section", tabName = "Main", icon = icon("far fa-chart-bar"))
    )
  ),
  dashboardBody(
    
    tabItems(tabItem(tabName = "Home"),
             
             tabItem(tabName = "Main",
                     fluidRow(
                     ),
                     
                     fluidRow(),
                     hr(),
                     
                     fluidRow(style = 'background: white;',
                              div(
                                box(
                                  title= "Much filters",
                                  style = 'height:420px; background: gainsboro; margin-top: 5vw;',
                                  width=3,
                                  solidHeader = TRUE,
                                  uiOutput("continent"),
                                  uiOutput("country")
                                ),
                                tabBox(
                                  width = 9,
                                  title = "Results",
                                  id = "tabset1",
                                  tabPanel(style = 'overflow-y:scroll;height:420px;',"Awesome results !",
                                           style="zoom: 90%;",
                                           DT::dataTableOutput("awesometable")
                                  )
                                )
                              )
                     )
             )
    )
  )
)

server <- function(input, output, session) {
  
  df <- gapminder::gapminder
  
  output$continent = renderUI({
    selectizeInput(inputId = "continent",
                   label = "Continent :",
                   choices = unique(df[,"continent"]),
                   selected = unique(df[,"continent"])[1])
  })
  
  datasub <- reactive({
    req(input$continent)
    df[df$continent == input$continent,]
  })
  
  output$country = renderUI({
    req(datasub())
    selectizeInput(inputId = "country",
                   label = "Country :",
                   choices = unique(datasub()[,"country"])
    )
  })
  
  datasub2 <- reactive({
    req(datasub(),input$country)
    datasub()[datasub()$country == input$country, ]
  })
  
  output$awesometable <- DT::renderDataTable({
    req(datasub2())
    datasub2()
  })
}

shinyApp(ui, server)

您还可以使用如下所示的模块。您可能需要调整要放置 selectInputs 的位置。

library(shiny)
library(data.table)
library(shiny)
library(gapminder)

moduleServer <- function(id, module) {
  callModule(module, id)
}

mod_chiffres_cles_ts_ui <- function(id){

  ns <- NS(id)
  tagList(
    box(
      title= "Filter",
      style = 'height:420px; background: gainsboro; margin-top: 3vw;',
      #width=3,
      solidHeader = TRUE,
      uiOutput(ns("mycontinent"))
    )
  )
}

mod_chiffres_cles_ts_server <- function(id,dat,var){
  moduleServer( id, function(input, output, session){
    ns <- session$ns
    df <- isolate(dat())
    
    output$mycontinent = renderUI({
      selectizeInput(inputId = ns("continent"),
                     label = paste(var, ":"),
                     choices = unique(df[,var]),
                     selected = unique(df[,var])[1])
    })
    
    #print(var)
    return(reactive(input$continent))

  })
}

mod_chiffres_cles_ds_server <- function(id,dat,var,value){
  moduleServer( id, function(input, output, session){
    
    df <- isolate(dat())
 
    datasub <- reactive({
      val = as.character(value())
      df[df[[as.name(var)]] == val,]
    })
    
    #print(var)
    return(reactive(as.data.frame(datasub())))
    
  })
}

ui <- dashboardPage(
  dashboardHeader(),
  dashboardSidebar(
    titlePanel(
      div(style="line-height: 100%",
          align = 'center',
          span("Awesome reprex"),
          hr()
      )
    ),
    sidebarMenu(
      menuItem("Home", tabName = "Home", icon = icon("fas fa-home")),
      menuItem("Main section", tabName = "Main", icon = icon("far fa-chart-bar"))
    )
  ),
  dashboardBody(
    
    tabItems(tabItem(tabName = "Home"),
             
             tabItem(tabName = "Main", 
                     fluidRow(
                       column(6,mod_chiffres_cles_ts_ui("gap1"), 
                              mod_chiffres_cles_ts_ui("gap2") 
                              ),
                       column(6,style = 'background: white;',
                              div(
                                tabBox(
                                  width = 12,
                                  title = "Results",
                                  id = "tabset1",
                                  tabPanel(style = 'overflow-y:scroll;height:560px;',"Awesome results !",
                                           style="zoom: 90%;",  
                                           DTOutput("awesometable")
                                  )
                                )
                              )
                              )
                             
                     )
             )
    )
  )
)


server <- function(input, output, session) {
  dfa <- reactive(gapminder)
  session$userData$settings <- reactiveValues(df1=NULL,df2=NULL)
  rv <- reactiveValues()
  var1 <- mod_chiffres_cles_ts_server("gap1",dfa,"continent")
  
  observeEvent(var1(), {
    data1 <- mod_chiffres_cles_ds_server("gap1",dfa,"continent", var1 )
    session$userData$settings$df1 <- data1()
    var21 <- mod_chiffres_cles_ts_server("gap2",data1,"country")
    df21 <- mod_chiffres_cles_ds_server("gap2",data1,"country", var21 )
    session$userData$settings$df2 <- df21()
    print(var21)
  })
  
  df22 <- reactive(session$userData$settings$df1)
  var22 <- mod_chiffres_cles_ts_server("gap2",df22,"country")
  
  observeEvent(var22(), {
    print(var22())
    data2 <- mod_chiffres_cles_ds_server("gap2",df22,"country",var22)
    session$userData$settings$df2 <- data2()
  })

  output$awesometable <- renderDT({
    datatable(session$userData$settings$df2)
  })
  
}

shinyApp(ui, server)

使用 {golem} 闪亮的相互依赖的过滤器模块化 reactiveUI

Modularize reactiveUI with interdependent filters in shiny with {golem}

r

shiny

shinydashboard

golem