Скрыть поля, если ввод не подходит в Shiny - PullRequest
Новая
       10

Скрыть поля, если ввод не подходит в Shiny

0 голосов
/ 11 декабря 2018

Я использую блестящую и блестящую панель.Есть пара случаев, когда я хотел бы, чтобы все или большинство ящиков / графиков были скрыты.

  1. Если диапазон дат невозможен (т.е. дата окончания предшествует дате начала).
  2. Если выбранные входы делают размер выборки слишком маленьким.

В выпуске 1 я хочу скрыть все поля и просто вернуть сообщение об ошибке.В выпуске 2 я хотел бы показать несколько инфобоксов вверху (например, размер выборки), но скрыть все остальные поля.

В настоящее время я создаю сообщение об ошибке, используя validate для первого условия, а также использую validate, чтобы остановить запуск графиков, когда это происходит.Однако, это все еще оставляет коробки, даже если они пусты, что довольно уродливо и грязно.

Я бы, наверное, мог бы поместить каждый ящик в условную панель, я думаю, но это кажется очень повторяющимся - наверняка есть более простой способ передать аргумент всем (или группе) ящиков?Этот код является примером - в приложении, над которым я работаю, есть намного больше блоков.

Пример кода: 

library(shiny)
library(shinydashboard)
library(tidyverse)


random_data <- data.frame(replicate(2, sample(0:10, 1000, rep=TRUE)))
set.seed(1984)
random_data$date <- sample(seq(as.Date('2016-01-01'), as.Date(Sys.Date()), by = "day"), 1000)

sidebar <- dashboardSidebar(dateRangeInput(
  "dates", label = h4("Date range"), start = '2016-01-01', end = Sys.Date(),
  format = "dd-mm-yyyy", startview = "year", min = "2016-01-01", max = Sys.Date()
))

body <- dashboardBody(
  textOutput("selected_dates"),
  br(),
  fluidRow(
        infoBoxOutput("total", width = 12)
  ),
  fluidRow(
    box(width = 12, solidHeader = TRUE,
        title = "X1 over time",
        plotOutput(outputId = "x1_time")
    )
  ),
  fluidRow(
    box(width = 12, solidHeader = TRUE,
        title = "X2 over time",
        plotOutput(outputId = "x2_time")
    )
  )
)

ui <- dashboardPage(dashboardHeader(title = "Example"),
                    sidebar,
                    body
)

server <- function(input, output) {
  filtered <- reactive({
    filtered_data <- random_data %>%
        filter(date >= input$dates[1] & date <= input$dates[2])
    return(filtered_data)
  })

  output$selected_dates <- renderText({
    validate(
      need(input$dates[2] >= input$dates[1], "End date is earlier than start date"
      )
    )
  })


  output$total<- renderInfoBox({
    validate(
      need(input$dates[2] >= input$dates[1], "")
    )
    infoBox(title = "Sample size", 
            value = nrow(filtered()), 
            icon = icon("binoculars"), color = "light-blue")
  })

  output$x1_time <- renderPlot({
    validate(
      need(input$dates[2] >= input$dates[1], "")
    )
    x1_time_plot <- ggplot(filtered(), aes(x = date, y = X1)) + 
      geom_bar(stat = "identity") 
      theme_minimal()
    x1_time_plot
  }) 

  output$x2_time <- renderPlot({
    validate(
      need(input$dates[2] >= input$dates[1], "")
    )
    x2_time_plot <- ggplot(filtered(), aes(x = date, y = X2)) + 
      geom_bar(stat = "identity") 
    theme_minimal()
    x2_time_plot
  }) 

}

shinyApp(ui, server)

1 Ответ

0 голосов
/ 11 декабря 2018

Вы можете использовать shinyjs и метод show / hide для всех inputIds, которые вы хотите скрыть или показать, или вы можете поместить все поля в div с классом и использовать команду hide / show сэтот класс или присвойте класс непосредственно fluidRows.В обоих примерах validate + need больше не требуется.

В этом примере показаны / скрыты отдельные выходные идентификаторы: 

library(shiny)
library(shinydashboard)
library(tidyverse)
library(shinyjs)

## DATA ##################
random_data <- data.frame(replicate(2, sample(0:10, 1000, rep=TRUE)))
set.seed(1984)
random_data$date <- sample(seq(as.Date('2016-01-01'), as.Date(Sys.Date()), by = "day"), 1000)

sidebar <- dashboardSidebar(dateRangeInput(
  "dates", label = h4("Date range"), start = '2016-01-01', end = Sys.Date(),
  format = "dd-mm-yyyy", startview = "year", min = "2016-01-01", max = Sys.Date()
))
##################

## UI ##################
body <- dashboardBody(
  useShinyjs(),
  textOutput("selected_dates"),
  br(),
  fluidRow(
    infoBoxOutput("total", width = 12)
  ),
  fluidRow(
    box(width = 12, solidHeader = TRUE,
        title = "X1 over time",
        plotOutput(outputId = "x1_time")
    )
  ),
  fluidRow(
    box(width = 12, solidHeader = TRUE,
        title = "X2 over time",
        plotOutput(outputId = "x2_time")
    )
  )
)

ui <- dashboardPage(dashboardHeader(title = "Example"),
                    sidebar,
                    body
)
##################


server <- function(input, output) {
  filtered <- reactive({
    filtered_data <- random_data %>%
      filter(date >= input$dates[1] & date <= input$dates[2])
    return(filtered_data)
  })

  observe({
    if (input$dates[2] < input$dates[1]) {
      shinyjs::hide("total")
      shinyjs::hide("x1_time")
      shinyjs::hide("x2_time")
    } else {
      shinyjs::show("total")
      shinyjs::show("x1_time")
      shinyjs::show("x2_time")
    }
  })

  output$total<- renderInfoBox({
    infoBox(title = "Sample size", 
            value = nrow(filtered()), 
            icon = icon("binoculars"), color = "light-blue")
  })

  output$x1_time <- renderPlot({
    x1_time_plot <- ggplot(filtered(), aes(x = date, y = X1)) + 
      geom_bar(stat = "identity") 
    theme_minimal()
    x1_time_plot
  }) 

  output$x2_time <- renderPlot({
    x2_time_plot <- ggplot(filtered(), aes(x = date, y = X2)) + 
      geom_bar(stat = "identity") 
    theme_minimal()
    x2_time_plot
  }) 

}

shinyApp(ui, server)

В этом примере используются классы для liquidRows, поэтому это будетскрыть всю главную страницу панели инструментов: 

## UI ##################
body <- dashboardBody(
  useShinyjs(),
  textOutput("selected_dates"),
  br(),
  fluidRow(class ="rowhide",
    infoBoxOutput("total", width = 12)
  ),
  fluidRow(class ="rowhide",
    box(width = 12, solidHeader = TRUE,
        title = "X1 over time",
        plotOutput(outputId = "x1_time")
    )
  ),
  fluidRow(class ="rowhide",
    box(width = 12, solidHeader = TRUE,
        title = "X2 over time",
        plotOutput(outputId = "x2_time")
    )
  )
)

ui <- dashboardPage(dashboardHeader(title = "Example"),
                    sidebar,
                    body
)
##################


server <- function(input, output) {
  filtered <- reactive({
    filtered_data <- random_data %>%
      filter(date >= input$dates[1] & date <= input$dates[2])
    return(filtered_data)
  })

  observe({
    if (input$dates[2] < input$dates[1]) {
      shinyjs::hide(selector = ".rowhide")
    } else {
      shinyjs::show(selector = ".rowhide")
    }
  })

  output$total<- renderInfoBox({
    infoBox(title = "Sample size", 
            value = nrow(filtered()), 
            icon = icon("binoculars"), color = "light-blue")
  })

  output$x1_time <- renderPlot({
    x1_time_plot <- ggplot(filtered(), aes(x = date, y = X1)) + 
      geom_bar(stat = "identity") 
    theme_minimal()
    x1_time_plot
  }) 

  output$x2_time <- renderPlot({
    x2_time_plot <- ggplot(filtered(), aes(x = date, y = X2)) + 
      geom_bar(stat = "identity") 
    theme_minimal()
    x2_time_plot
  }) 

}

shinyApp(ui, server)
...