基于窗口大小的闪亮动态内容（如 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并获取窗口的宽度。我在解决方案上遇到了一些麻烦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获取窗口的宽度。（免责声明：我在JS 代码中使用了以下SO 主题中接受的答案。）

我添加了一个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 和媒体查询

您可以控制indisplay中的属性。它适用于任何元素，但我发现它不适用于. media-querytags$headUIOutput

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