Shiny dynamic content based on window size (like css media query)

Question

I have some plots in a panel. I want to change them into tabsetpanel when the window width is small. Is there any way in shiny to determine window width of browser. For example, in the following example, how can I switch uiOutput from plotPanel1 to plotPanel2 when the window width is large enough.

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

Since Shiny is generating a bunch of HTML you could use media-query, or another possibility is to use javaScript and get the width of the window. I had some trouble with the css solution, but I will show you both:

Approach #1 (Working): Using javaScript

With javaScript you can define an input element based on the width of the window:

  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);
                        });
                        '))

If this script is included in the UI, you can then access input$width to obtain the width of the window. (Disclaimer: I used the accepted answer in the following SO topic for the JS code.)

I added an observer to check the width. If it is below/above a certain threshold then the elements are shown/hidden.

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

Full code:

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

This is not a perfect solution in my opinion, since we are rendering every plot twice, however you can probably build on this.

Approach #2 (NOT working): CSS and media-query

You can control the display attribute within a media-query in tags$head. It works fine for any element, however I found that it doesn't work well with UIOutput.

Working example for simple div with 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")
)

Not working example for 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))