基于窗口大小的闪亮动态内容（如 CSS 媒体查询）

Posted 2023-03-24

【中文标题】基于窗口大小的闪亮动态内容（如 CSS 媒体查询）

【英文标题】：Shiny dynamic content based on window size (like css media query)

【发布时间】：2018-04-27 18:51:52

【问题描述】：

我在面板中有一些情节。当窗口宽度较小时，我想将它们更改为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))

【参考方案1】：

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

方法 #1（工作）：使用 javaScript

使用javaScript，您可以根据窗口的width 定义输入元素：

  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 以获取窗口的宽度。 （免责声明：我在下面的SO topic 中使用了接受的答案作为 JS 代码。）

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

  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。

简单的div 和text 的工作示例：

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))

【讨论】：

请注意，您现在可以使用 shinybrowser 包替换所有 javascript，而不是添加一堆自定义 javascript

太棒了，干得好！ @DeanAttali