带有条件 plotOut 的闪亮仪表板

Question

我刚开始使用闪亮和仪表板，因此非常感谢任何帮助！

我有一个闪亮的仪表板应用程序，其中一行显示两个元素：左侧是 tabBox，右侧是两个 tabPanel，右侧是 box（用于显示绘图）。

我想要的是根据活动的tabPanel 在框中显示一个特定的图。当第一个选项卡处于活动状态时，绘图应该不可点击，但在第二个选项卡处于活动状态时可点击。

我的问题是我只知道如何使用选项click = "plot_click"通过plotOutput函数在ui中设置可点击属性。但这将两个图都设置为可点击的。当然，删除选项click = "plot_click" 会将两个图都设置为不可点击。如何使 clickable 属性依赖于活动选项卡？

我尝试了什么：在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根据活动的tabPanel定义plotOutput的特征。以下是您使用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()（不再需要）。
• 在第一个 renderUI() 调用中将 plot2 更改为 plot1。

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

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