Блестящая приборная панель с условным сюжетом - PullRequest
Новая
       6

Блестящая приборная панель с условным сюжетом

2 голосов
/ 26 февраля 2020

Я только начинаю с блестящей и приборной панели, поэтому любая помощь очень ценится!

У меня есть приложение shinydashboard, отображающее одну строку с двумя элементами: A tabBox слева с двумя tabPanel s и box справа (для отображения графика).

Мне нужно отобразить конкретный график в поле в зависимости от активного tabPanel. График должен быть не активируемым , когда активна первая вкладка, но активируемым , когда активна вторая вкладка.

Моя проблема в том, что я знаю только, как установить вверх по кликабельному свойству в ui через функцию plotOutput, используя опцию click = "plot_click". Но это делает оба графика кликабельными. Конечно, удаление опции click = "plot_click" делает оба графика неактивными. Как сделать свойство clickable зависимым от активной вкладки?

Что я пробовал: Поместить оператор if внутри box() так, чтобы в зависимости от идентификатора tabPanel, это активирует опцию 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)

Заранее спасибо, jorge

Ответы [ 2 ]

1 голос
/ 26 февраля 2020

Вы можете использовать uiOutput для определения характеристик plotOutput в соответствии с активным tabPanel. Ниже ваш пример адаптирован с 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.

0 голосов
/ 26 февраля 2020

Спасибо, bretauv , это решает это!

Мне все еще нужно было добавить два последних изменения в код, чтобы получить точно то, что я хотел:

  • Удалите plotOutput () внутри box (больше не требуется).
  • Измените plot2 на plot1 внутри первого renderUI() вызова.

Возможно, вы захотите отредактировать свой ответ, используя эти советы, для дальнейшего использования.

Большое спасибо! Я проголосовал за этот ответ.

...