2

光沢のあるモジュールを多用する光沢のあるダッシュボードに取り組んでおり、クライアントから、ダッシュボードのさまざまなタブからの同じ 2 つの入力がタブに関係なく同じ値になるようにするように依頼されました。私はこれを行うのに大きな問題を抱えており、以下にあるおもちゃの例を使用して再現することができました.

#app.R

library(data.table)
library(shiny)
library(ggplot2)
library(ggthemes)
library(shinythemes)
source("Modules.R")

penguins <<- as.data.table(palmerpenguins::penguins)

ui = uiOutput("ui")
inputs <<- reactiveValues(species = NULL, island = NULL)

server <- function(input, output, session) {
  bill_species_server("tab1")
  flipper_mass_scatter_server("tab2")
  
  output$ui = renderUI({
    fluidPage(
      titlePanel("", "Penguin Dashboard"),
       tabsetPanel(
         tabPanel("Bill Length by Species",
                ui_code("tab1")
        ),
        tabPanel("Flipper Length by Body Mass",
                 ui_code("tab2")
        )
      )
    )
  })
}

# Run the application 
shinyApp(ui = ui, server = server)

#Modules.R

ui_code = function (id) {
  ns = NS(id)
  
  sidebarLayout(position = "left",
    sidebarPanel(
      selectInput(ns("species"), "Choose 1+ species:", choices = penguins[, sort(unique(species))], multiple = TRUE),
      selectInput(ns("island"), "Choose 1+ islands:", choices = penguins[, sort(unique(island))], multiple = TRUE)
    ),
    mainPanel(
      plotOutput(ns("plot"))
    )
  )
}

bill_species_server = function(id) {
  
  moduleServer(id, function(input, output, session) {
    
    observeEvent(inputs$species, ignoreInit = TRUE, ignoreNULL = TRUE, {
      if (length(inputs$species) > 0) {
        updateSelectInput(session = session, inputId = "species", selected = inputs$species)
      }
    })
    
    observeEvent(inputs$island, ignoreInit = TRUE, ignoreNULL = TRUE, {
      if (length(inputs$island) > 0) {
        updateSelectInput(session = session, inputId = "island", selected = inputs$island)
      }
      
    })
    
    output$plot = renderPlot({
      
      if (length(input$species) > 0) {
        penguins = penguins[species %in% input$species]
      }
      
      if (length(input$island) > 0) {
        penguins = penguins[island %in% input$island]
      }
      
      ggplot(penguins) + geom_histogram(aes(x = `bill_length_mm`, fill = species)) + scale_fill_canva(palette = "Striking and energetic")
    })
    
    observeEvent(input$species, ignoreNULL = TRUE, ignoreInit = TRUE, {
      inputs$species = input$species
    })
    
    observeEvent(input$island, ignoreNULL = TRUE, ignoreInit = TRUE, {
      inputs$island = input$island
    })
    
    
  })
  return(inputs)
}

flipper_mass_scatter_server = function (id) {
  

  moduleServer(id, function(input, output, session) {
    
    observeEvent(inputs$species, ignoreInit = TRUE, ignoreNULL = TRUE, {
      if (length(inputs$species) > 0) {
        updateSelectInput(session = session, inputId = "species", selected = inputs$species)
      }
    })
    
    observeEvent(inputs$island, ignoreInit = TRUE, ignoreNULL = TRUE, {
      if (length(inputs$island) > 0) {
        updateSelectInput(session = session, inputId = "island", selected = inputs$island)
      }
      
    })
    
    output$plot = renderPlot({
      
      if (length(input$species) > 0) {
        penguins = penguins[species %in% input$species]
      }
      
      if (length(input$island) > 0) {
        penguins = penguins[island %in% input$island]
      }
      
      ggplot(penguins) + geom_point(aes(x = `flipper_length_mm`, y = body_mass_g, colour = species)) + scale_colour_canva(palette = "Striking and energetic")
    })
    
    observeEvent(input$species, ignoreNULL = TRUE, ignoreInit = TRUE, {
      inputs$species = input$species
    })
    
    observeEvent(input$island, ignoreNULL = TRUE, ignoreInit = TRUE, {
      inputs$island = input$island
    })
  })
  return(inputs)
}

したがって、このおもちゃの例でリンクしようとしている 2 つの入力はspeciesとislandです。誰かがいずれかの入力で新しい選択を行ったときに、オブザーバーがグローバル変数を更新する必要があるように設定しましたinputs。そして、inputs更新された場合、他のタブは独自の selectInput を更新する必要があります。

奇妙なことに、このコードでは、選択をゆっくりと行うと、すべてがうまく機能することがわかりました。ただし、2 つ以上の選択肢を立て続けにクリックすると、現在のタブで無限ループが発生し、2 つ目の選択肢が表示されてから消え、次に表示されます。逆に、3 つの選択肢を選択してオプションを立て続けに削除しようとしても、すべての選択肢を削除することはできません!!

とても奇妙。

私のコードに問題があること、および両方のタブの入力を強制的に他のタブで選択した値と同じ値に保つ方法を知っている人はいますか?

ありがとう！

4

1 に答える 1

0

この問題へのアプローチ方法を大幅に再構築し、解決策を考え出しました。基本的には、shinydashboard を使用し、モジュールの外部で thespeciesおよびislandselectInput コントロールを定義することにしました。

これらのコントロールへの値は、データがプロットされる前にデータをフィルタリングするために使用されるリアクティブ オブジェクトとしてモジュールに渡されました。これは今ではとてもうまく機能します！私の2つのファイルを見てください：

#app.R

library(data.table)
library(shiny)
library(ggplot2)
library(ggthemes)
library(shinythemes)
library(shinydashboard)
source("Modules.R")

penguins <<- as.data.table(palmerpenguins::penguins)

ui = dashboardPage(header = dashboardHeader(title = "Penguin Dashboard"),
                    sidebar = dashboardSidebar(
                     sidebarMenu(id = "tabs",
                                 selectInput("species", "Choose 1+ species:", choices = penguins[, sort(unique(species))], multiple = TRUE),
                                 selectInput("island", "Choose 1+ islands:", choices = penguins[, sort(unique(island))], multiple = TRUE),
                                 menuItem("Bill Length by Species", expandedName = "tab1", tabName = "tab1", startExpanded = TRUE,
                                          sliderInput("mass", "Select a range of body masses:", 
                                                      min = penguins[, min(body_mass_g, na.rm=TRUE)],
                                                      max = penguins[, max(body_mass_g, na.rm=TRUE)], 
                                                      value = penguins[, range(body_mass_g, na.rm=TRUE)])
                                          ),
                                 menuItem("Flipper Length by Body Mass", expandedName = "tab2", tabName = "tab2",
                                          checkboxGroupInput("sex", "Choose sex of penguins:", 
                                                             choices = c("male","female")))
                     )),
                     body = dashboardBody(
                       uiOutput("plots")
                       )
)

#inputs <<- reactiveValues(species = NULL, island = NULL)

server <- function(input, output, session) {
  #inputs <- reactiveValues(species=input$species, island=input$island)
  
  in_species = reactive({input$species})
  in_island = reactive({input$island})
  in_mass = reactive({input$mass})
  in_sex = reactive({input$sex})
  
  bill_species_server("tab1", in_species, in_island, in_mass)
  flipper_mass_scatter_server("tab2", in_species, in_island, in_sex)
  
  output$plots = renderUI({
    validate(need(!is.null(input$sidebarItemExpanded), ""))
    
    if (input$sidebarItemExpanded == "tab1") {
      ui_code("tab1")
    } else {
      ui_code("tab2")
    }
    
  })
}

# Run the application 
shinyApp(ui = ui, server = server)


#Modules.R

ui_code = function (id) {
  ns = NS(id)
  
      plotOutput(ns("plot"))
}

bill_species_server = function(id, in_species, in_island, in_mass) {
  
  moduleServer(id, function(input, output, session) {
    
    ns <- session$ns
    
    output$plot = renderPlot({

      if (length(in_species()) > 0) {
        penguins = penguins[species %in% in_species()]
      }

      if (length(in_island()) > 0) {
        penguins = penguins[island %in% in_island()]
      }
      
      penguins = penguins[body_mass_g %between% c(in_mass()[1], in_mass()[2])]
      
      ggplot(penguins) + geom_histogram(aes(x = `bill_length_mm`, fill = species)) + scale_fill_canva(palette = "Striking and energetic")
    })
  })
  
}

flipper_mass_scatter_server = function (id, in_species, in_island, in_sex) {
  

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

    output$plot = renderPlot({

      if (length(in_species()) > 0) {
        penguins = penguins[species %in% in_species()]
      }
      
      if (length(in_island()) > 0) {
        penguins = penguins[island %in% in_island()]
      }
      
      if (length(in_sex()) > 0) {
        penguins = penguins[sex %in% in_sex()]
      }
      
      ggplot(penguins) + geom_point(aes(x = `flipper_length_mm`, y = body_mass_g, colour = species)) + scale_colour_canva(palette = "Striking and energetic")
    })

  })
  
}
于 2021-03-24T14:14:44.857 に答える