r - 基于窗口大小的 Shiny 动态内容(如 CSS 媒体查询)

Question

我在面板中有一些图。我想当窗口宽度较小时将它们更改为 tabsetpanel 。有什么方法可以确定浏览器的窗口宽度。例如，在下面的示例中，当窗口宽度足够大时，如何将 uiOutput 从 plotPanel1 切换到 plotPanel2。

library(ggplot2)

ui <- fluidPage(
  title = "TestApp",
  h1("Test Application"),
  sidebarLayout(
    sidebarPanel(
      sliderInput("bins", "Bins", 2, 20, 1, value = 10)
    ),
    mainPanel(
      fluidRow(
        uiOutput("plotPanel1")
      )
    )
  )
)
server <- function(input, output, session){
  output$plot1 <- renderPlot({
    mdl <- lm(mpg ~ ., data = mtcars)
    ggplot(mdl, aes(.resid)) + geom_histogram(bins = input$bins)
  }, res = 110)
  output$plot2 <- renderPlot({
    mdl <- lm(UrbanPop ~ ., data = USArrests)
    ggplot(mdl, aes(.resid)) + geom_histogram(bins = input$bins)
  }, res = 110)
  output$plot3 <- renderPlot({
    mdl <- lm(uptake ~ ., data = CO2)
    ggplot(mdl, aes(.resid)) + geom_histogram(bins = input$bins)
  }, res = 110)
  output$plotPanel1 <- renderUI({
    tabsetPanel(
      tabPanel(
        "plot1",
        plotOutput("plot1")
      ),
      tabPanel(
        "plot2",
        plotOutput("plot2")
      ),
      tabPanel(
        "plot3",
        plotOutput("plot3")
      )
    )
  })
  output$plotPanel2 <- renderUI({
    fluidRow(
      column(
        4,
        plotOutput("plot1")
      ),
      column(
        4,
        plotOutput("plot2")
      ),
      column(
        4,
        plotOutput("plot3")
      )
    )
  })
}

runApp(shinyApp(ui, server))

Answer 1

由于 Shiny 正在生成一堆 HTML，您可以使用 media-query，或者另一种可能性是使用 javaScript 并获取宽度 window 的。我在使用 css 解决方案时遇到了一些问题，但我会向您展示:

方法#1(工作):使用 javaScript

使用javaScript，您可以根据窗口的宽度定义输入元素:

  tags$head(tags$script('
                        var width = 0;
                        $(document).on("shiny:connected", function(e) {
                          width = window.innerWidth;
                          Shiny.onInputChange("width", width);
                        });
                        $(window).resize(function(e) {
                          width = window.innerWidth;
                          Shiny.onInputChange("width", width);
                        });
                        '))

如果此脚本包含在UI中，则您可以访问input$width来获取窗口的宽度。 (免责声明:我在 JS 代码中使用了以下 SO topic 中接受的答案。)

我添加了一个观察者来检查宽度。如果低于/高于某个阈值，则显示/隐藏元素。

  observe( {
    req(input$width)
    if(input$width < 800) {
      shinyjs::show("plotPanel1")
      shinyjs::hide("plotPanel2")
    } else {
      shinyjs::hide("plotPanel1")
      shinyjs::show("plotPanel2")
    }
  })

完整代码:

library(shinyjs)
library(ggplot2)

ui <- fluidPage(
  useShinyjs(),
  title = "TestApp",
  h1("Test Application"),
  sidebarLayout(
    sidebarPanel(
      sliderInput("bins", "Bins", 2, 20, 1, value = 10)
    ),
    mainPanel(
      fluidRow(
        div(id="p1", uiOutput("plotPanel1")),
        div(id="p2", uiOutput("plotPanel2"))
      )
    )
  ),
  tags$head(tags$script('
                        var width = 0;
                        $(document).on("shiny:connected", function(e) {
                          width = window.innerWidth;
                          Shiny.onInputChange("width", width);
                        });
                        $(window).resize(function(e) {
                          width = window.innerWidth;
                          Shiny.onInputChange("width", width);
                        });
                        '))
)

server <- function(input, output, session){
  plot1 <- reactive({
    ggplot(lm(mpg ~ ., data = mtcars), aes(.resid)) +
      geom_histogram(bins = input$bins)
  }) 
  plot2 <- reactive({
    ggplot(lm(UrbanPop ~ ., data = USArrests), aes(.resid)) +
      geom_histogram(bins = input$bins)
  }) 
  plot3 <- reactive({
    ggplot(lm(uptake ~ ., data = CO2), aes(.resid)) +
      geom_histogram(bins = input$bins)
  })

  output$plotPanel1 <- renderUI({
    tagList(
      tabsetPanel(
        tabPanel(
          "plot1",
          renderPlot(plot1())
        ),
        tabPanel(
          "plot2",
          renderPlot(plot2())
        ),
        tabPanel(
          "plot3",
          renderPlot(plot3())
        )
      )
    )
  })

  output$plotPanel2 <- renderUI({
    tagList(
      fluidRow(
        column(
          4,
          renderPlot(plot1())
        ),
        column(
          4,
          renderPlot(plot2())
        ),
        column(
          4,
          renderPlot(plot3())
        )
      ) 
    )  
  })

  observe( {
    req(input$width)
    if(input$width < 800) {
      shinyjs::show("plotPanel1")
      shinyjs::hide("plotPanel2")
    } else {
      shinyjs::hide("plotPanel1")
      shinyjs::show("plotPanel2")
    }
  })
}

runApp(shinyApp(ui, server))

在我看来，这不是一个完美的解决方案，因为我们将每个图渲染两次，但是您可以在此基础上进行构建。

方法#2(不起作用):CSS 和媒体查询

您可以在 tags$head 的 media-query 中控制 display 属性。它适用于任何元素，但我发现它不适用于 UIOutput。

带有text的简单div的工作示例:

ui <- fluidPage(
  tags$head(
    tags$style(HTML("
      @media screen and (min-width: 1000px) {
        #p1 {
          display: none;
        }

        #p2 {
          display: block;
        }
      }

      @media screen and (max-width: 1000px) {
        #p1 {
          display: block;
        }

        #p2 {
          display: none;
        }
      }
      "
    ))
    ),
    div(id="p1", "First element"),
    div(id="p2", "Second element")
)

UIOutput 不起作用的示例:

ui <- fluidPage(
  title = "TestApp",
  h1("Test Application"),
  sidebarLayout(
    sidebarPanel(
      sliderInput("bins", "Bins", 2, 20, 1, value = 10)
    ),
    mainPanel(
      fluidRow(
          div(id="p1", uiOutput("plotPanel1")),
          div(id="p2", uiOutput("plotPanel2"))
      )
    )
  ),
  tags$head(
    tags$style(HTML("
      @media screen and (min-width: 1000px) {
        #plotPanel1 {
          display: none;
        }

        #plotPanel2 {
          display: block;
        }
      }

      @media screen and (max-width: 1000px) {
        #plotPanel1 {
          display: block;
        }

        #plotPanel2 {
          display: none;
        }
      }
      "
    ))
    )
)
server <- function(input, output, session){
  plot1 <- reactive({
    ggplot(lm(mpg ~ ., data = mtcars), aes(.resid)) +
      geom_histogram(bins = input$bins)
  }) 
  plot2 <- reactive({
    ggplot(lm(UrbanPop ~ ., data = USArrests), aes(.resid)) +
      geom_histogram(bins = input$bins)
  }) 
  plot3 <- reactive({
    ggplot(lm(uptake ~ ., data = CO2), aes(.resid)) +
      geom_histogram(bins = input$bins)
  })

  output$plotPanel1 <- renderUI({
    tagList(
      tabsetPanel(
        tabPanel(
          "plot1",
          renderPlot(plot1())
        ),
        tabPanel(
          "plot2",
          renderPlot(plot2())
        ),
        tabPanel(
          "plot3",
          renderPlot(plot3())
        )
      ) 
    )
  })
  output$plotPanel2 <- renderUI({
    tagList(
      fluidRow(
        column(
          4,
          renderPlot(plot1())
        ),
        column(
          4,
          renderPlot(plot2())
        ),
        column(
          4,
          renderPlot(plot3())
        )
      ) 
    )
  })
}

runApp(shinyApp(ui, server))