Skip to content

Instantly share code, notes, and snippets.

@nanxstats
Created June 4, 2023 23:19
Show Gist options
  • Save nanxstats/59e91cc32548c1522ebff55ef6facd20 to your computer and use it in GitHub Desktop.
Save nanxstats/59e91cc32548c1522ebff55ef6facd20 to your computer and use it in GitHub Desktop.
Responsive design for statistical graphics with Shiny and ggplot2
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)
@nanxstats
Copy link
Author

responsive-ggplot2.mp4

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment