|
| 1 | +# Dashboard for the figure: change its settings and download the result. |
| 2 | +# Run locally from the repository root with shiny::runApp("app"). |
| 3 | +# The plots come from R/figure.R, the same code that figure_example.R runs. |
| 4 | + |
| 5 | +library(shiny) |
| 6 | +library(bslib) |
| 7 | + |
| 8 | +`%||%` <- function(x, y) if (is.null(x)) y else x # base R has it only from 4.4 |
| 9 | + |
| 10 | +# R/figure.R, data/ and images/ sit next to this file in the Shinylive bundle, |
| 11 | +# and one level up in the repository |
| 12 | +root <- if (file.exists("R/figure.R")) "." else ".." |
| 13 | +source(file.path(root, "R", "figure.R"), local = TRUE) |
| 14 | + |
| 15 | +# ggplotGrob() in the panel builders draws on the current device. Use a null pdf device: |
| 16 | +# no Rplots.pdf, and no cairo device (cairo crashes in webR once magick is loaded). |
| 17 | +pdf(NULL) |
| 18 | + |
| 19 | +fig_data <- load_figure_data(file.path(root, "data"), file.path(root, "images")) |
| 20 | +defaults <- figure_defaults() |
| 21 | + |
| 22 | +# Settings each panel uses: a panel is rebuilt only when one of these changes |
| 23 | +panel_settings <- list( |
| 24 | + A = character(), |
| 25 | + B = c("base_size", "group_colours", "sigma", "show_inset", "show_polygons"), |
| 26 | + C = c("base_size", "group_colours", "jitter_seed", "point_alpha"), |
| 27 | + D = c("base_size", "shear_constant", "width_line", "velocity_line"), |
| 28 | + E = c("base_size", "decay", "ribbon_width"), |
| 29 | + F = c("base_size", "viridis_option") |
| 30 | +) |
| 31 | +panel_builders <- list(A = panel_a, B = panel_b, C = panel_c, D = panel_d, E = panel_e, F = panel_f) |
| 32 | +# Built panels, shared by all sessions. An explicit cache: Shinylive sets up no default app cache. |
| 33 | +panel_cache <- cachem::cache_mem(max_size = 100 * 1024^2) |
| 34 | + |
| 35 | +viridis_options <- c("magma (A)" = "A", "inferno (B)" = "B", "plasma (C)" = "C", "viridis (D)" = "D", |
| 36 | + "cividis (E)" = "E", "rocket (F)" = "F", "mako (G)" = "G", "turbo (H)" = "H") |
| 37 | + |
| 38 | +save_png <- function(plot, file, width, height, dpi) { |
| 39 | + ggsave(file, plot, width = width, height = height, dpi = dpi, bg = "white", device = ragg::agg_png) |
| 40 | +} |
| 41 | + |
| 42 | +# Draws one panel in its place in the 3 x 2 figure, with empty cells around it, and trims the |
| 43 | +# white space. Drawn alone, the panel would not match the figure: patchwork aligns the panels, |
| 44 | +# and the insets in B and D are placed for the layout of the whole figure. |
| 45 | +save_panel_png <- function(panel, id, file, dpi) { |
| 46 | + spacer <- plot_spacer() + theme(aspect.ratio = 1) # all panels have aspect ratio 1 |
| 47 | + cells <- rep(list(spacer), 6) |
| 48 | + cells[[match(id, LETTERS[1:6])]] <- panel + labs(tag = id) |
| 49 | + save_png(wrap_plots(cells, ncol = 3, nrow = 2), file, fig_width, fig_height, dpi) |
| 50 | + |
| 51 | + image <- magick::image_trim(magick::image_read(file)) |
| 52 | + image <- magick::image_border(image, "white", geometry = paste0(dpi %/% 8, "x", dpi %/% 8)) |
| 53 | + magick::image_write(image, file, format = "png") |
| 54 | +} |
| 55 | + |
| 56 | +# Colour input ---- |
| 57 | + |
| 58 | +# A native <input type="color"> with a small Shiny input binding (no extra package) |
| 59 | +colour_input <- function(id, label, value) { |
| 60 | + div(class = "form-group shiny-input-container", |
| 61 | + tags$label(`for` = id, class = "control-label", label), |
| 62 | + tags$input(id = id, type = "color", value = value, class = "scifig-colour form-control form-control-color")) |
| 63 | +} |
| 64 | + |
| 65 | +colour_binding_js <- " |
| 66 | +const colourBinding = new Shiny.InputBinding(); |
| 67 | +$.extend(colourBinding, { |
| 68 | + find: (scope) => $(scope).find('input.scifig-colour'), |
| 69 | + getValue: (el) => el.value, |
| 70 | + setValue: (el, value) => { el.value = value; }, |
| 71 | + receiveMessage: (el, data) => { el.value = data.value; $(el).trigger('change'); }, |
| 72 | + subscribe: (el, callback) => $(el).on('input.scifig change.scifig', () => callback(true)), |
| 73 | + unsubscribe: (el) => $(el).off('.scifig'), |
| 74 | + getRatePolicy: () => ({ policy: 'debounce', delay: 250 }) |
| 75 | +}); |
| 76 | +Shiny.inputBindings.register(colourBinding, 'scifig.colour'); |
| 77 | +" |
| 78 | + |
| 79 | +# UI ---- |
| 80 | + |
| 81 | +settings_panel <- accordion( |
| 82 | + open = "Figure", |
| 83 | + accordion_panel( |
| 84 | + "Figure", |
| 85 | + sliderInput("base_size", "Base font size", min = 8, max = 16, step = 0.5, value = defaults$base_size), |
| 86 | + helpText("The insets in panels B and D are placed for the default size; other sizes can shift labels."), |
| 87 | + checkboxGroupInput("panels", "Panels", choices = LETTERS[1:6], selected = defaults$panels, inline = TRUE), |
| 88 | + colour_input("colour1", "Colour 1 (B: apical side, C: mutant)", defaults$group_colours[1]), |
| 89 | + colour_input("colour2", "Colour 2 (B: basal side, C: wildtype)", defaults$group_colours[2]) |
| 90 | + ), |
| 91 | + accordion_panel( |
| 92 | + "B: neighbor numbers", |
| 93 | + sliderInput("sigma", "Lognormal sigma", min = 0.05, max = 0.5, step = 0.01, value = defaults$sigma), |
| 94 | + input_switch("show_inset", "Interior angle inset", value = defaults$show_inset), |
| 95 | + input_switch("show_polygons", "Polygons below the axis", value = defaults$show_polygons) |
| 96 | + ), |
| 97 | + accordion_panel( |
| 98 | + "C: tracheal length", |
| 99 | + numericInput("jitter_seed", "Jitter seed", value = defaults$jitter_seed, min = 1, step = 1), |
| 100 | + sliderInput("point_alpha", "Point opacity", min = 0.05, max = 1, step = 0.05, value = defaults$point_alpha) |
| 101 | + ), |
| 102 | + accordion_panel( |
| 103 | + "D: shear stress", |
| 104 | + numericInput("shear_constant", "Shear stress constant", value = defaults$shear_constant, min = 0, step = 0.5), |
| 105 | + helpText("shear stress = constant / (π · 18 · width²)"), |
| 106 | + numericInput("width_line", "Dashed line: lumen width b (µm)", value = defaults$width_line, |
| 107 | + min = 0.5, max = 50, step = 0.1), |
| 108 | + numericInput("velocity_line", "Dashed line: relative velocity", value = defaults$velocity_line, |
| 109 | + min = 0, max = 1, step = 0.05) |
| 110 | + ), |
| 111 | + accordion_panel( |
| 112 | + "E: concentration", |
| 113 | + numericInput("decay1", "Decay constant, dashed curve (h)", value = defaults$decay[1], min = 1, step = 1), |
| 114 | + numericInput("decay2", "Decay constant, solid curve (h)", value = defaults$decay[2], min = 1, step = 1), |
| 115 | + numericInput("decay3", "Decay constant, dotted curve (h)", value = defaults$decay[3], min = 1, step = 1), |
| 116 | + sliderInput("ribbon_width", "Band around the solid curve (± %)", min = 0, max = 50, step = 1, |
| 117 | + value = defaults$ribbon_width * 100) |
| 118 | + ), |
| 119 | + accordion_panel( |
| 120 | + "F: Hill coefficients", |
| 121 | + selectInput("viridis_option", "Colour palette", choices = viridis_options, selected = defaults$viridis_option) |
| 122 | + ) |
| 123 | +) |
| 124 | + |
| 125 | +ui <- page_sidebar( |
| 126 | + title = "Scientific figure dashboard", |
| 127 | + tags$head(tags$script(HTML(colour_binding_js))), |
| 128 | + sidebar = sidebar( |
| 129 | + width = 320, |
| 130 | + settings_panel, |
| 131 | + actionButton("reset", "Reset to defaults", icon = icon("rotate-left")) |
| 132 | + ), |
| 133 | + navset_card_underline( |
| 134 | + nav_panel( |
| 135 | + "Figure", |
| 136 | + imageOutput("figure_preview", height = "auto"), |
| 137 | + card_footer( |
| 138 | + div(class = "d-flex flex-wrap gap-2 align-items-center", |
| 139 | + selectInput("png_dpi", NULL, width = "180px", |
| 140 | + choices = c("PNG, 96 dpi" = 96, "PNG, 150 dpi" = 150, "PNG, 300 dpi" = 300)), |
| 141 | + downloadButton("download_png", "Download PNG", class = "mb-3"), |
| 142 | + downloadButton("download_svg", "Download SVG", class = "mb-3")) |
| 143 | + ) |
| 144 | + ), |
| 145 | + nav_panel( |
| 146 | + "Panel", |
| 147 | + radioButtons("single_panel", NULL, choices = LETTERS[1:6], selected = "B", inline = TRUE), |
| 148 | + imageOutput("panel_preview", height = "auto") |
| 149 | + ), |
| 150 | + nav_panel( |
| 151 | + "About", |
| 152 | + div(class = "p-2", style = "max-width: 700px;", |
| 153 | + p("This page shows the example figure from", |
| 154 | + a("scifig_plot_examples_R", href = "https://github.com/macromeer/scifig_plot_examples_R", |
| 155 | + target = "_blank"), |
| 156 | + "and lets you change its settings and download the result as PNG or SVG."), |
| 157 | + p("The plots are made by the same R code as", code("figure_example.R"), |
| 158 | + "(", code("R/figure.R"), "). The app runs R in your browser (webR), so nothing is sent to a server."), |
| 159 | + p("The figure is drawn at a fixed size (1148 × 686 px at 96 dpi), because the insets in panels B", |
| 160 | + "and D are positioned for that size. The downloads use the same size; higher dpi only adds pixels.", |
| 161 | + "Fonts can differ slightly from the PNG/SVG/PDF that the script writes.") |
| 162 | + ) |
| 163 | + ) |
| 164 | + ) |
| 165 | +) |
| 166 | + |
| 167 | +# Server ---- |
| 168 | + |
| 169 | +# Settings from the inputs. Inputs that are not set (yet) keep their default. |
| 170 | +read_opts <- function(input) { |
| 171 | + opts <- defaults |
| 172 | + set <- function(name, value) if (!is.null(value)) opts[[name]] <<- value |
| 173 | + set_element <- function(name, i, value) if (!is.null(value)) opts[[name]][i] <<- value |
| 174 | + for (name in c("base_size", "sigma", "show_inset", "show_polygons", "jitter_seed", "point_alpha", |
| 175 | + "shear_constant", "width_line", "velocity_line", "viridis_option")) { |
| 176 | + set(name, input[[name]]) |
| 177 | + } |
| 178 | + for (i in 1:2) set_element("group_colours", i, input[[paste0("colour", i)]]) |
| 179 | + for (i in 1:3) set_element("decay", i, input[[paste0("decay", i)]]) |
| 180 | + if (!is.null(input$ribbon_width)) opts$ribbon_width <- input$ribbon_width / 100 |
| 181 | + opts$panels <- input$panels %||% character() # unticking every box gives NULL |
| 182 | + opts |
| 183 | +} |
| 184 | + |
| 185 | +# Messages for settings that can't be drawn |
| 186 | +check_opts <- function(opts) { |
| 187 | + numbers <- c(opts$jitter_seed, opts$shear_constant, opts$width_line, opts$velocity_line, opts$decay) |
| 188 | + c( |
| 189 | + if (anyNA(numbers)) "Fill in every number field.", |
| 190 | + if (length(opts$panels) == 0) "Select at least one panel.", |
| 191 | + if (isTRUE(opts$shear_constant <= 0)) "The shear stress constant must be positive.", |
| 192 | + if (isTRUE(opts$width_line < 0.5 || opts$width_line > 50)) "The lumen width line must be between 0.5 and 50 µm.", |
| 193 | + if (isTRUE(opts$velocity_line < 0 || opts$velocity_line > 1)) "The velocity line must be between 0 and 1.", |
| 194 | + if (isTRUE(any(opts$decay <= 0))) "Decay constants must be positive." |
| 195 | + ) |
| 196 | +} |
| 197 | + |
| 198 | +server <- function(input, output, session) { |
| 199 | + opts <- reactive({ |
| 200 | + opts <- read_opts(input) |
| 201 | + problems <- check_opts(opts) |
| 202 | + validate(need(length(problems) == 0, paste(problems, collapse = "\n"))) |
| 203 | + opts |
| 204 | + }) |> debounce(500) |
| 205 | + |
| 206 | + # One cached reactive per panel, keyed by the settings that panel uses |
| 207 | + panels <- lapply(setNames(nm = names(panel_builders)), function(id) { |
| 208 | + reactive(panel_builders[[id]](fig_data, opts())) |> |
| 209 | + bindCache(opts()[panel_settings[[id]]], id, cache = panel_cache) |
| 210 | + }) |
| 211 | + |
| 212 | + figure <- reactive({ |
| 213 | + selected <- opts()$panels |
| 214 | + build_figure(lapply(setNames(nm = selected), function(id) panels[[id]]())) |
| 215 | + }) |
| 216 | + |
| 217 | + output$figure_preview <- renderImage({ |
| 218 | + file <- tempfile(fileext = ".png") |
| 219 | + save_png(figure(), file, fig_width, fig_height, dpi = 96) |
| 220 | + list(src = file, contentType = "image/png", alt = "Figure preview", |
| 221 | + style = "width: 100%; max-width: 1148px; height: auto;") |
| 222 | + }, deleteFile = TRUE) |
| 223 | + |
| 224 | + output$panel_preview <- renderImage({ |
| 225 | + file <- tempfile(fileext = ".png") |
| 226 | + # same size in inches as in the figure, more pixels: same layout, just bigger |
| 227 | + save_panel_png(panels[[input$single_panel]](), input$single_panel, file, dpi = 240) |
| 228 | + list(src = file, contentType = "image/png", alt = paste("Panel", input$single_panel), |
| 229 | + style = "width: 100%; max-width: 760px; height: auto;") |
| 230 | + }, deleteFile = TRUE) |
| 231 | + |
| 232 | + output$download_png <- downloadHandler( |
| 233 | + filename = "figure.png", |
| 234 | + content = function(file) save_png(figure(), file, fig_width, fig_height, dpi = as.numeric(input$png_dpi %||% 96)) |
| 235 | + ) |
| 236 | + output$download_svg <- downloadHandler( |
| 237 | + filename = "figure.svg", |
| 238 | + content = function(file) { |
| 239 | + ggsave(file, figure(), width = fig_width, height = fig_height, bg = "white", device = svglite::svglite) |
| 240 | + } |
| 241 | + ) |
| 242 | + |
| 243 | + observeEvent(input$reset, { |
| 244 | + for (id in c("base_size", "sigma", "point_alpha")) updateSliderInput(session, id, value = defaults[[id]]) |
| 245 | + updateSliderInput(session, "ribbon_width", value = defaults$ribbon_width * 100) |
| 246 | + for (id in c("jitter_seed", "shear_constant", "width_line", "velocity_line")) { |
| 247 | + updateNumericInput(session, id, value = defaults[[id]]) |
| 248 | + } |
| 249 | + for (i in 1:3) updateNumericInput(session, paste0("decay", i), value = defaults$decay[i]) |
| 250 | + for (id in c("show_inset", "show_polygons")) update_switch(id, value = defaults[[id]], session = session) |
| 251 | + updateCheckboxGroupInput(session, "panels", selected = defaults$panels) |
| 252 | + updateSelectInput(session, "viridis_option", selected = defaults$viridis_option) |
| 253 | + session$sendInputMessage("colour1", list(value = defaults$group_colours[1])) |
| 254 | + session$sendInputMessage("colour2", list(value = defaults$group_colours[2])) |
| 255 | + }) |
| 256 | +} |
| 257 | + |
| 258 | +shinyApp(ui, server) |
0 commit comments