帶有條件 plotOut 的閃亮儀表板

Question

我剛開始使用閃亮的儀表板，因此非常感謝您的幫助！

我有一個 Shinydashboard 應用程序顯示一行，其中包含兩個元素：左側的tabBox帶有兩個tabPanel s，右側的一個box （用於顯示繪圖）。

我想要的是根據活動tabPanel在框中顯示特定圖。 當第一個選項卡處於活動狀態時，該圖不應可單擊，但在第二個選項卡處於活動狀態時可單擊。

我的問題是我只知道如何使用選項click = "plot_click"通過plotOutput函數在ui設置 clickable 屬性。 但這將兩個圖都設置為可點擊。 當然，刪除選項click = "plot_click"將兩個圖都設置為不可點擊。 如何使可點擊屬性依賴於活動選項卡？

我嘗試過的：在box()放置一個if語句，這樣，根據tabPanel的 ID，它會激活選項click = "plot_click"以獲得正確的繪圖。 我失敗了。

這是代碼。 您可以通過（取消）注釋box()內的所需圖來玩任一圖。

library(shiny)
library(shinydashboard)
library(ggplot2)

ui <- dashboardPage(

  dashboardHeader(title = "Conditional plotOutput click", titleWidth = 450),

  dashboardSidebar(disable = TRUE), 

  dashboardBody(

    fluidRow(
      tabBox(title = "Choose tab", id = "choose.tab", height = 250, selected = "Automatic", 
             tabPanel(title = "Automatic", id = "auto", sliderInput("slider", "Nobs:", 1, 10, 5)), 
             tabPanel(title = "Manual", id = "man")
      ), 

      box(title = "Plot", solidHeader = TRUE, 
          # plotOutput("plot1", height = 250)                     # Try me!
          plotOutput("plot2", height = 250, click = "plot_click") # Or me!
      )
    )
  )
)

server <- function(input, output) {
  set.seed(123)

  react.vals <- reactiveValues( 
    df     = data.frame(x = numeric(), y = numeric()), 
    plot1  = ggplot(), 
    plot2  = ggplot()
  )

  # Plot 1 - Automatic scatterplot:
  observe({
    scatter.data     <- data.frame(x = runif(input$slider), y = runif(input$slider))
    react.vals$plot1 <- ggplot(scatter.data, aes(x, y)) + geom_point(color = "red", size = 4) + 
      scale_x_continuous("x", breaks = seq(0, 1, .2), limits = c(0, 1), expand = c(0,0)) +
      scale_y_continuous("y", breaks = seq(0, 1, .2), limits = c(0, 1), expand = c(0,0)) + 
      theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank())
  })
  observeEvent(react.vals$plot1, { 
    output$plot1 <- renderPlot({ react.vals$plot1 })
  })

  # Plot 2 - Manual scatterplot through clicking:
  observeEvent(input$plot_click, {
    new.point     <- data.frame(x = input$plot_click$x,
                                y = input$plot_click$y)
    react.vals$df <- rbind(react.vals$df, new.point)
  })
  observe({
    react.vals$plot2 <- ggplot(react.vals$df, aes(x = x, y = y)) + geom_point(color = "red", size = 4) + 
      scale_x_continuous("x", breaks = seq(0, 1, .2), limits = c(0, 1), expand = c(0,0)) +
      scale_y_continuous("y", breaks = seq(0, 1, .2), limits = c(0, 1), expand = c(0,0)) + 
      theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank())
  })
  observeEvent(react.vals$plot2, { 
    output$plot2 <- renderPlot({ react.vals$plot2 })
  })
}

shinyApp(ui, server)

提前致謝，豪爾赫

Answer 1

您可以使用uiOutput定義的特性plotOutput根據活動tabPanel 。 以下是您使用uiOutput改編的uiOutput ：

library(shiny)
library(shinydashboard)
library(ggplot2)

ui <- dashboardPage(

  dashboardHeader(title = "Conditional plotOutput click", titleWidth = 450),

  dashboardSidebar(disable = TRUE), 

  dashboardBody(

    fluidRow(
      tabBox(title = "Choose tab", id = "choose_tab", height = 250, selected = "Automatic", 
             tabPanel(title = "Automatic", id = "auto", sliderInput("slider", "Nobs:", 1, 10, 5)), 
             tabPanel(title = "Manual", id = "man")
      ), 

      box(title = "Plot", solidHeader = TRUE, 
          uiOutput("test")
      )
    )
  )
)

server <- function(input, output) {
  set.seed(123)

  react.vals <- reactiveValues( 
    df     = data.frame(x = numeric(), y = numeric()), 
    plot1  = ggplot(), 
    plot2  = ggplot()
  )

  observe({
    if (input$choose_tab == "Automatic") {
      output$test <- renderUI({
        plotOutput("plot1", height = 250)
      })
    }
    else if(input$choose_tab == "Manual") {
      output$test <- renderUI({
        plotOutput("plot2", height = 250, click = "plot_click")
      })
    }
  })

  # Plot 1 - Automatic scatterplot:
  observe({
    scatter.data     <- data.frame(x = runif(input$slider), y = runif(input$slider))
    react.vals$plot1 <- ggplot(scatter.data, aes(x, y)) + geom_point(color = "red", size = 4) + 
      scale_x_continuous("x", breaks = seq(0, 1, .2), limits = c(0, 1), expand = c(0,0)) +
      scale_y_continuous("y", breaks = seq(0, 1, .2), limits = c(0, 1), expand = c(0,0)) + 
      theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank())
  })
  observeEvent(react.vals$plot1, { 
    output$plot1 <- renderPlot({ react.vals$plot1 })
  })

  # Plot 2 - Manual scatterplot through clicking:
  observeEvent(input$plot_click, {
    new.point     <- data.frame(x = input$plot_click$x,
                                y = input$plot_click$y)
    react.vals$df <- rbind(react.vals$df, new.point)
  })
  observe({
    react.vals$plot2 <- ggplot(react.vals$df, aes(x = x, y = y)) + geom_point(color = "red", size = 4) + 
      scale_x_continuous("x", breaks = seq(0, 1, .2), limits = c(0, 1), expand = c(0,0)) +
      scale_y_continuous("y", breaks = seq(0, 1, .2), limits = c(0, 1), expand = c(0,0)) + 
      theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank())
  })
  observeEvent(react.vals$plot2, { 
    output$plot2 <- renderPlot({ react.vals$plot2 })
  })
}

shinyApp(ui, server)

編輯：修復了 R 代碼中的一個小錯字。

Answer 2

謝謝， bretauv ，這解決了！

我仍然需要對代碼添加兩個最終更改以完全滿足我的要求：

• 刪除box的 plotOutput() （不再需要）。
• 更改plot2到plot1第一內側renderUI()調用。

也許您想使用這些提示編輯您的答案以供將來參考。

非常感謝！ 我已經贊成這個答案。