带有条件 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()调用。

也许您想使用这些提示编辑您的答案以供将来参考。

非常感谢！ 我已经赞成这个答案。