From 4d8157c7324b85aef9570d30da41b9374e5c3691 Mon Sep 17 00:00:00 2001 From: macromeer Date: Tue, 6 Oct 2026 15:37:12 +0200 Subject: [PATCH] Add a dashboard app for the figure app/app.R is a Shiny (bslib) app that builds the figure with the functions in R/figure.R. The sidebar exposes the settings from figure_defaults(): font size, panels, the two group colours, the panel B model and inset switches, the panel C jitter, the panel D constant and dashed lines, the panel E decay constants and band, and the panel F palette, plus a reset button. Tabs show the full figure, one panel at a larger size, and an about page. The figure downloads as PNG (96, 150 or 300 dpi) or SVG. The figure is always drawn at the script's fixed size, since the insets in panels B and D are placed for it. The panel tab draws the panel in its cell of the 3 x 2 layout and trims the empty space, so it matches the figure. Each panel is rebuilt only when one of its own settings changes. The app runs as is under Shinylive (webR): no cairo devices (they crash in webR once magick is loaded) and an explicit bindCache() cache (Shinylive sets up no default one). tests/testthat/test-app.R checks the server logic with testServer(): defaults, settings reaching the panels, panel selection, messages for invalid settings, the panel tab and both downloads. shiny, bslib and ragg are added to Suggests so CI installs them. Co-Authored-By: Claude Opus 5.5 --- DESCRIPTION | 11 +- README.md | 14 ++- app/app.R | 258 ++++++++++++++++++++++++++++++++++++++ tests/testthat/test-app.R | 77 ++++++++++++ 4 files changed, 355 insertions(+), 5 deletions(-) create mode 100644 app/app.R create mode 100644 tests/testthat/test-app.R diff --git a/DESCRIPTION b/DESCRIPTION index 5426328..4d8e384 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,9 +1,11 @@ Package: scifigexamples Title: Scientific Publication Figure Plotting Examples with R Version: 0.1.0 -Description: Example script for a multi-panel scientific figure. This is not - an R package: the file only lists the dependencies, so they can be - installed with pak::local_install_deps() and in CI. +Description: Example script for a multi-panel scientific figure, and a + dashboard app for it (app/, needs the suggested packages bslib, ragg + and shiny). This is not an R package: the file only lists the + dependencies, so they can be installed with pak::local_install_deps() + and in CI. License: GPL-3 Encoding: UTF-8 Depends: @@ -19,6 +21,9 @@ Imports: svglite, systemfonts Suggests: + bslib, + ragg, + shiny, testthat (>= 3.0.0), vdiffr, withr diff --git a/README.md b/README.md index 099819f..7dd0878 100644 --- a/README.md +++ b/README.md @@ -21,22 +21,32 @@ This writes `figure_example.png`, `figure_example.svg` and `figure_example.pdf`. To change font size, colours or model parameters, edit `opts` in `figure_example.R` (all settings and their defaults are listed in `figure_defaults()` in `R/figure.R`). +## Dashboard + +`app/` is a Shiny app for the figure: change font size, colours, model parameters and which panels to show, and download the result as PNG or SVG. It uses the same plotting code (`R/figure.R`). To run it locally: + +```r +install.packages(c("shiny", "bslib", "ragg")) +shiny::runApp("app") +``` + ## Layout | Path | Contents | |---|---| | `figure_example.R` | Script that builds and saves the figure | | `R/figure.R` | Functions for the figure: data loading, one function per panel, saving | +| `app/` | Dashboard app (Shiny) | | `data/` | CSV data for panels B–F | | `images/` | Microscopy images for panel A | | `tests/` | Tests (see below) | ## Tests -The tests check the data loading, that every panel renders without warnings (also with non-default settings), the exported files, and how each panel looks (visual snapshots with vdiffr). They run on GitHub Actions for every push and pull request. To run them locally: +The tests check the data loading, that every panel renders without warnings (also with non-default settings), the exported files, the dashboard's server logic, and how each panel looks (visual snapshots with vdiffr). They run on GitHub Actions for every push and pull request. To run them locally: ```r -install.packages(c("testthat", "vdiffr", "withr")) +install.packages(c("testthat", "vdiffr", "withr", "shiny", "bslib", "ragg")) ``` ```sh diff --git a/app/app.R b/app/app.R new file mode 100644 index 0000000..1b22b53 --- /dev/null +++ b/app/app.R @@ -0,0 +1,258 @@ +# Dashboard for the figure: change its settings and download the result. +# Run locally from the repository root with shiny::runApp("app"). +# The plots come from R/figure.R, the same code that figure_example.R runs. + +library(shiny) +library(bslib) + +`%||%` <- function(x, y) if (is.null(x)) y else x # base R has it only from 4.4 + +# R/figure.R, data/ and images/ sit next to this file in the Shinylive bundle, +# and one level up in the repository +root <- if (file.exists("R/figure.R")) "." else ".." +source(file.path(root, "R", "figure.R"), local = TRUE) + +# ggplotGrob() in the panel builders draws on the current device. Use a null pdf device: +# no Rplots.pdf, and no cairo device (cairo crashes in webR once magick is loaded). +pdf(NULL) + +fig_data <- load_figure_data(file.path(root, "data"), file.path(root, "images")) +defaults <- figure_defaults() + +# Settings each panel uses: a panel is rebuilt only when one of these changes +panel_settings <- list( + A = character(), + B = c("base_size", "group_colours", "sigma", "show_inset", "show_polygons"), + C = c("base_size", "group_colours", "jitter_seed", "point_alpha"), + D = c("base_size", "shear_constant", "width_line", "velocity_line"), + E = c("base_size", "decay", "ribbon_width"), + F = c("base_size", "viridis_option") +) +panel_builders <- list(A = panel_a, B = panel_b, C = panel_c, D = panel_d, E = panel_e, F = panel_f) +# Built panels, shared by all sessions. An explicit cache: Shinylive sets up no default app cache. +panel_cache <- cachem::cache_mem(max_size = 100 * 1024^2) + +viridis_options <- c("magma (A)" = "A", "inferno (B)" = "B", "plasma (C)" = "C", "viridis (D)" = "D", + "cividis (E)" = "E", "rocket (F)" = "F", "mako (G)" = "G", "turbo (H)" = "H") + +save_png <- function(plot, file, width, height, dpi) { + ggsave(file, plot, width = width, height = height, dpi = dpi, bg = "white", device = ragg::agg_png) +} + +# Draws one panel in its place in the 3 x 2 figure, with empty cells around it, and trims the +# white space. Drawn alone, the panel would not match the figure: patchwork aligns the panels, +# and the insets in B and D are placed for the layout of the whole figure. +save_panel_png <- function(panel, id, file, dpi) { + spacer <- plot_spacer() + theme(aspect.ratio = 1) # all panels have aspect ratio 1 + cells <- rep(list(spacer), 6) + cells[[match(id, LETTERS[1:6])]] <- panel + labs(tag = id) + save_png(wrap_plots(cells, ncol = 3, nrow = 2), file, fig_width, fig_height, dpi) + + image <- magick::image_trim(magick::image_read(file)) + image <- magick::image_border(image, "white", geometry = paste0(dpi %/% 8, "x", dpi %/% 8)) + magick::image_write(image, file, format = "png") +} + +# Colour input ---- + +# A native with a small Shiny input binding (no extra package) +colour_input <- function(id, label, value) { + div(class = "form-group shiny-input-container", + tags$label(`for` = id, class = "control-label", label), + tags$input(id = id, type = "color", value = value, class = "scifig-colour form-control form-control-color")) +} + +colour_binding_js <- " +const colourBinding = new Shiny.InputBinding(); +$.extend(colourBinding, { + find: (scope) => $(scope).find('input.scifig-colour'), + getValue: (el) => el.value, + setValue: (el, value) => { el.value = value; }, + receiveMessage: (el, data) => { el.value = data.value; $(el).trigger('change'); }, + subscribe: (el, callback) => $(el).on('input.scifig change.scifig', () => callback(true)), + unsubscribe: (el) => $(el).off('.scifig'), + getRatePolicy: () => ({ policy: 'debounce', delay: 250 }) +}); +Shiny.inputBindings.register(colourBinding, 'scifig.colour'); +" + +# UI ---- + +settings_panel <- accordion( + open = "Figure", + accordion_panel( + "Figure", + sliderInput("base_size", "Base font size", min = 8, max = 16, step = 0.5, value = defaults$base_size), + helpText("The insets in panels B and D are placed for the default size; other sizes can shift labels."), + checkboxGroupInput("panels", "Panels", choices = LETTERS[1:6], selected = defaults$panels, inline = TRUE), + colour_input("colour1", "Colour 1 (B: apical side, C: mutant)", defaults$group_colours[1]), + colour_input("colour2", "Colour 2 (B: basal side, C: wildtype)", defaults$group_colours[2]) + ), + accordion_panel( + "B: neighbor numbers", + sliderInput("sigma", "Lognormal sigma", min = 0.05, max = 0.5, step = 0.01, value = defaults$sigma), + input_switch("show_inset", "Interior angle inset", value = defaults$show_inset), + input_switch("show_polygons", "Polygons below the axis", value = defaults$show_polygons) + ), + accordion_panel( + "C: tracheal length", + numericInput("jitter_seed", "Jitter seed", value = defaults$jitter_seed, min = 1, step = 1), + sliderInput("point_alpha", "Point opacity", min = 0.05, max = 1, step = 0.05, value = defaults$point_alpha) + ), + accordion_panel( + "D: shear stress", + numericInput("shear_constant", "Shear stress constant", value = defaults$shear_constant, min = 0, step = 0.5), + helpText("shear stress = constant / (π · 18 · width²)"), + numericInput("width_line", "Dashed line: lumen width b (µm)", value = defaults$width_line, + min = 0.5, max = 50, step = 0.1), + numericInput("velocity_line", "Dashed line: relative velocity", value = defaults$velocity_line, + min = 0, max = 1, step = 0.05) + ), + accordion_panel( + "E: concentration", + numericInput("decay1", "Decay constant, dashed curve (h)", value = defaults$decay[1], min = 1, step = 1), + numericInput("decay2", "Decay constant, solid curve (h)", value = defaults$decay[2], min = 1, step = 1), + numericInput("decay3", "Decay constant, dotted curve (h)", value = defaults$decay[3], min = 1, step = 1), + sliderInput("ribbon_width", "Band around the solid curve (± %)", min = 0, max = 50, step = 1, + value = defaults$ribbon_width * 100) + ), + accordion_panel( + "F: Hill coefficients", + selectInput("viridis_option", "Colour palette", choices = viridis_options, selected = defaults$viridis_option) + ) +) + +ui <- page_sidebar( + title = "Scientific figure dashboard", + tags$head(tags$script(HTML(colour_binding_js))), + sidebar = sidebar( + width = 320, + settings_panel, + actionButton("reset", "Reset to defaults", icon = icon("rotate-left")) + ), + navset_card_underline( + nav_panel( + "Figure", + imageOutput("figure_preview", height = "auto"), + card_footer( + div(class = "d-flex flex-wrap gap-2 align-items-center", + selectInput("png_dpi", NULL, width = "180px", + choices = c("PNG, 96 dpi" = 96, "PNG, 150 dpi" = 150, "PNG, 300 dpi" = 300)), + downloadButton("download_png", "Download PNG", class = "mb-3"), + downloadButton("download_svg", "Download SVG", class = "mb-3")) + ) + ), + nav_panel( + "Panel", + radioButtons("single_panel", NULL, choices = LETTERS[1:6], selected = "B", inline = TRUE), + imageOutput("panel_preview", height = "auto") + ), + nav_panel( + "About", + div(class = "p-2", style = "max-width: 700px;", + p("This page shows the example figure from", + a("scifig_plot_examples_R", href = "https://github.com/macromeer/scifig_plot_examples_R", + target = "_blank"), + "and lets you change its settings and download the result as PNG or SVG."), + p("The plots are made by the same R code as", code("figure_example.R"), + "(", code("R/figure.R"), "). The app runs R in your browser (webR), so nothing is sent to a server."), + p("The figure is drawn at a fixed size (1148 × 686 px at 96 dpi), because the insets in panels B", + "and D are positioned for that size. The downloads use the same size; higher dpi only adds pixels.", + "Fonts can differ slightly from the PNG/SVG/PDF that the script writes.") + ) + ) + ) +) + +# Server ---- + +# Settings from the inputs. Inputs that are not set (yet) keep their default. +read_opts <- function(input) { + opts <- defaults + set <- function(name, value) if (!is.null(value)) opts[[name]] <<- value + set_element <- function(name, i, value) if (!is.null(value)) opts[[name]][i] <<- value + for (name in c("base_size", "sigma", "show_inset", "show_polygons", "jitter_seed", "point_alpha", + "shear_constant", "width_line", "velocity_line", "viridis_option")) { + set(name, input[[name]]) + } + for (i in 1:2) set_element("group_colours", i, input[[paste0("colour", i)]]) + for (i in 1:3) set_element("decay", i, input[[paste0("decay", i)]]) + if (!is.null(input$ribbon_width)) opts$ribbon_width <- input$ribbon_width / 100 + opts$panels <- input$panels %||% character() # unticking every box gives NULL + opts +} + +# Messages for settings that can't be drawn +check_opts <- function(opts) { + numbers <- c(opts$jitter_seed, opts$shear_constant, opts$width_line, opts$velocity_line, opts$decay) + c( + if (anyNA(numbers)) "Fill in every number field.", + if (length(opts$panels) == 0) "Select at least one panel.", + if (isTRUE(opts$shear_constant <= 0)) "The shear stress constant must be positive.", + if (isTRUE(opts$width_line < 0.5 || opts$width_line > 50)) "The lumen width line must be between 0.5 and 50 µm.", + if (isTRUE(opts$velocity_line < 0 || opts$velocity_line > 1)) "The velocity line must be between 0 and 1.", + if (isTRUE(any(opts$decay <= 0))) "Decay constants must be positive." + ) +} + +server <- function(input, output, session) { + opts <- reactive({ + opts <- read_opts(input) + problems <- check_opts(opts) + validate(need(length(problems) == 0, paste(problems, collapse = "\n"))) + opts + }) |> debounce(500) + + # One cached reactive per panel, keyed by the settings that panel uses + panels <- lapply(setNames(nm = names(panel_builders)), function(id) { + reactive(panel_builders[[id]](fig_data, opts())) |> + bindCache(opts()[panel_settings[[id]]], id, cache = panel_cache) + }) + + figure <- reactive({ + selected <- opts()$panels + build_figure(lapply(setNames(nm = selected), function(id) panels[[id]]())) + }) + + output$figure_preview <- renderImage({ + file <- tempfile(fileext = ".png") + save_png(figure(), file, fig_width, fig_height, dpi = 96) + list(src = file, contentType = "image/png", alt = "Figure preview", + style = "width: 100%; max-width: 1148px; height: auto;") + }, deleteFile = TRUE) + + output$panel_preview <- renderImage({ + file <- tempfile(fileext = ".png") + # same size in inches as in the figure, more pixels: same layout, just bigger + save_panel_png(panels[[input$single_panel]](), input$single_panel, file, dpi = 240) + list(src = file, contentType = "image/png", alt = paste("Panel", input$single_panel), + style = "width: 100%; max-width: 760px; height: auto;") + }, deleteFile = TRUE) + + output$download_png <- downloadHandler( + filename = "figure.png", + content = function(file) save_png(figure(), file, fig_width, fig_height, dpi = as.numeric(input$png_dpi %||% 96)) + ) + output$download_svg <- downloadHandler( + filename = "figure.svg", + content = function(file) { + ggsave(file, figure(), width = fig_width, height = fig_height, bg = "white", device = svglite::svglite) + } + ) + + observeEvent(input$reset, { + for (id in c("base_size", "sigma", "point_alpha")) updateSliderInput(session, id, value = defaults[[id]]) + updateSliderInput(session, "ribbon_width", value = defaults$ribbon_width * 100) + for (id in c("jitter_seed", "shear_constant", "width_line", "velocity_line")) { + updateNumericInput(session, id, value = defaults[[id]]) + } + for (i in 1:3) updateNumericInput(session, paste0("decay", i), value = defaults$decay[i]) + for (id in c("show_inset", "show_polygons")) update_switch(id, value = defaults[[id]], session = session) + updateCheckboxGroupInput(session, "panels", selected = defaults$panels) + updateSelectInput(session, "viridis_option", selected = defaults$viridis_option) + session$sendInputMessage("colour1", list(value = defaults$group_colours[1])) + session$sendInputMessage("colour2", list(value = defaults$group_colours[2])) + }) +} + +shinyApp(ui, server) diff --git a/tests/testthat/test-app.R b/tests/testthat/test-app.R new file mode 100644 index 0000000..def0be0 --- /dev/null +++ b/tests/testthat/test-app.R @@ -0,0 +1,77 @@ +# Server logic of the dashboard (app/app.R), without a browser + +skip_if_not_installed("shiny") +skip_if_not_installed("bslib") +skip_if_not_installed("ragg") + +app <- shiny::shinyAppDir(file.path(repo_root, "app")) + +# testServer() doesn't run the UI, so inputs start unset (= defaults), except the +# panel checkboxes: unset is the same as none ticked +start <- function(session, ...) { + session$setInputs(panels = LETTERS[1:6], ...) + session$elapse(600) # settings are debounced +} + +test_that("the app starts from the script's default settings", { + shiny::testServer(app, { + start(session) + expect_equal(opts(), fig$figure_defaults()) + expect_s3_class(figure(), "patchwork") + expect_match(output$figure_preview$src, "^data:image/png;base64,") + }) +}) + +test_that("settings reach the panels", { + shiny::testServer(app, { + start(session, viridis_option = "B", ribbon_width = 30, colour1 = "#1b9e77", decay1 = 24, + show_inset = FALSE) + expect_equal(opts()$viridis_option, "B") + expect_equal(opts()$ribbon_width, 0.3) + expect_equal(opts()$group_colours, c("#1b9e77", fig$figure_defaults()$group_colours[2])) + expect_equal(opts()$decay, c(24, 60, 72)) + expect_false(opts()$show_inset) + for (id in names(panels)) expect_no_warning(ggplotGrob(panels[[id]]()), message = id) + }) +}) + +test_that("only the selected panels are in the figure", { + shiny::testServer(app, { + session$setInputs(panels = c("B", "E")) + session$elapse(600) + expect_equal(opts()$panels, c("B", "E")) + expect_no_warning(ggplotGrob(figure())) + }) +}) + +test_that("settings that can't be drawn give a message instead of a figure", { + shiny::testServer(app, { + start(session, shear_constant = -1) + expect_error(opts(), "shear stress constant must be positive") + session$setInputs(shear_constant = 33.28, decay2 = NA) + session$elapse(600) + expect_error(opts(), "Fill in every number field") + session$setInputs(decay2 = 60, panels = NULL) + session$elapse(600) + expect_error(opts(), "Select at least one panel") + }) +}) + +test_that("the panel tab shows the chosen panel", { + shiny::testServer(app, { + start(session, single_panel = "D") + expect_match(output$panel_preview$src, "^data:image/png;base64,") + }) +}) + +test_that("the downloads write a PNG at the chosen resolution and an SVG", { + shiny::testServer(app, { + start(session, png_dpi = "150") + png <- magick::image_info(magick::image_read(output$download_png)) + expect_equal(c(png$width, png$height), round(c(1148, 686) * 150 / 96), tolerance = 1) + + svg <- readLines(output$download_svg, warn = FALSE) + expect_match(svg[1], "^<\\?xml") + expect_true(any(grepl("