Responsive design for statistical graphics with Shiny and ggplot2

responsive-ggplot2.R

library("shiny")
library("ggplot2")

# Container max widths from Bootstrap 5
max_width <- c(540, 720, 960, 1140, 1320)

# Output image height scaling factors
height_scale <- c(6, 3, 3, 1.5, 1, 1)

# Given plot width, find the grid interval index while considering page columns
find_width_index <- function(width, column) {
  findInterval(width, max_width / column) + 1
}

# Generate a faceted plot with varying number of columns and font size
plot_responsive <- function(index, ncol, base_size) {
  p <- ggplot(mpg, aes(displ, hwy, color = class)) +
    geom_point() +
    ggsci::scale_color_d3(alpha = 0.6) +
    theme(legend.position = "none")
  p <- p + facet_wrap(vars(class), ncol = ncol[index]) +
    theme_linedraw(base_size = base_size[index]) +
    theme(legend.position = "none")
  p
}

# Save plot with proper width and height while considering page columns
save_responsive <- function(expr, width, height, column, factor = 100) {
  index <- find_width_index(width, column = column)

  outfile <- tempfile(fileext = ".svg")
  svglite::svglite(
    outfile,
    width = width / factor,
    height = height * height_scale[index] / factor
  )
  p <- eval(expr)
  print(p)
  dev.off()

  invisible(outfile)
}

card <- function(title, ...) {
  htmltools::tags$div(
    class = "card",
    htmltools::tags$div(class = "card-header", title),
    htmltools::tags$div(class = "card-body", ...),
    htmltools::tags$style(".card, .card-header { border-color: #333; }")
  )
}

ui <- fluidPage(
  theme = bslib::bs_theme(version = 5),
  htmltools::tags$style("body { margin-top: 15px; }"),
  htmltools::tags$style(".card, .card-header { border-color: #fff; }"),
  fluidRow(
    h2("1 column"),
    column(12, card("Column 1", imageOutput("p1", height = "auto")))
  ),
  p(),
  fluidRow(
    h2("2 columns"),
    column(6, card("Column 1", imageOutput("p2", height = "auto"))),
    column(6, card("Column 2", imageOutput("p3", height = "auto"))),
  )
)

server <- function(input, output, session) {
  output$p1 <- renderImage(
    {
      width <- session$clientData$output_p1_width
      height <- session$clientData$output_p1_height
      height <- if (is.null(height) || height < 1 || height > 399.5) 400 else height
      index <- find_width_index(width, column = 1)
      outfile <- index |>
        plot_responsive(ncol = c(1, 2, 3, 4, 6, 8), base_size = c(14, 14, 12, 12, 14, 14)) |>
        save_responsive(width, height, column = 1)
      list(src = outfile, width = width, height = height * height_scale[index])
    },
    deleteFile = TRUE
  )
  output$p2 <- renderImage(
    {
      width <- session$clientData$output_p2_width
      height <- session$clientData$output_p2_height
      height <- if (is.null(height) || height < 1 || height > 399.5) 400 else height
      index <- find_width_index(width, column = 2)
      outfile <- index |>
        plot_responsive(ncol = c(1, 1, 1, 2, 4, 4), base_size = c(15, 15, 14, 14, 12, 12)) |>
        save_responsive(width, height, column = 2)
      list(src = outfile, width = width, height = height * height_scale[index])
    },
    deleteFile = TRUE
  )
  output$p3 <- renderImage(
    {
      width <- session$clientData$output_p3_width
      height <- session$clientData$output_p3_height
      height <- if (is.null(height) || height < 1 || height > 399.5) 400 else height
      index <- find_width_index(width, column = 2)
      outfile <- index |>
        plot_responsive(ncol = c(1, 1, 1, 2, 4, 4), base_size = c(15, 15, 14, 14, 12, 12)) |>
        save_responsive(width, height, column = 2)
      list(src = outfile, width = width, height = height * height_scale[index])
    },
    deleteFile = TRUE
  )
}

shinyApp(ui, server)

responsive-ggplot2.mp4