r-基于窗口大小的闪亮动态内容(如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和媒体查询

可以在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))