andreas/FreesearchR
1
0
Fork 0
mirror of https://github.com/agdamsbo/FreesearchR.git synced 2026-06-19 12:37:30 +02:00
Code Issues Projects Releases Packages Wiki Activity

transformed for a new pragmatic compromise to dynamically load additional input options where available

Browse source
This commit is contained in:
Andreas Gammelgaard Damsbo 2026-05-30 19:55:45 +02:00
commit f774b90d07
No known key found for this signature in database
1 changed files with 105 additions and 775 deletions
Download patch file Download diff file Expand all files Collapse all files

854
R/data_plots.R
View file

@ -14,12 +14,23 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) {
list(
bslib::layout_sidebar(
sidebar = bslib::sidebar(
shiny::actionButton(
inputId = ns("act_plot"),
label = i18n$t("Plot"),
width = "100%",
icon = phosphoricons::ph("paint-brush", weight = "bold"),
# icon = shiny::icon("palette"),
disabled = FALSE
),
shiny::helpText(
i18n$t('Adjust plot input and settings below, then press "Plot".')
),
bslib::accordion(
id = "acc_plot",
multiple = FALSE,
bslib::accordion_panel(
value = "acc_pan_plot",
title = "Create plot",
title = i18n$t("Define plot"),
icon = phosphoricons::ph("chart-line"),
# icon = bsicons::bs_icon("graph-up"),
shiny::uiOutput(outputId = ns("primary")),
@ -30,20 +41,15 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) {
),
shiny::tags$br(),
shiny::uiOutput(outputId = ns("type")),
shiny::uiOutput(outputId = ns("basic_parameters")),
# shiny::uiOutput(outputId = ns("secondary")),
# shiny::uiOutput(outputId = ns("tertiary")),
shiny::uiOutput(outputId = ns("color_palette")),
shiny::br(),
shiny::actionButton(
inputId = ns("act_plot"),
label = i18n$t("Plot"),
width = "100%",
icon = phosphoricons::ph("paint-brush",weight = "bold"),
# icon = shiny::icon("palette"),
disabled = FALSE
shiny::uiOutput(outputId = ns("secondary")),
shiny::uiOutput(outputId = ns("tertiary"))
),
shiny::helpText(i18n$t('Adjust settings, then press "Plot".'))
bslib::accordion_panel(
value = "acc_pan_params",
title = i18n$t("Settings"),
icon = phosphoricons::ph("gear"),
shiny::uiOutput(outputId = ns("color_palette")),
shiny::uiOutput(outputId = ns("basic_parameters")),
),
bslib::accordion_panel(
value = "acc_pan_download",
@ -120,10 +126,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) {
#' @name data-plots
#' @returns shiny server module
#' @export
data_visuals_server <- function(id,
data,
palettes,
...) {
data_visuals_server <- function(id, data, palettes = color_choices(), ...) {
shiny::moduleServer(
id = id,
module = function(input, output, session) {
@ -175,8 +178,7 @@ data_visuals_server <- function(id,
plot_data <- data()[input$primary]
}
plots <- possible_plots(data = plot_data,
source_list=available_plots())
plots <- possible_plots(data = plot_data, source_list = available_plots())
plots_named <- get_input_params(plots) |>
lapply(\(.x) {
@ -203,39 +205,60 @@ data_visuals_server <- function(id,
})
### Include two additional variable inputs
output$secondary <- shiny::renderUI({
shiny::req(input$type)
# Get the plot function name
base_params <- rv$plot.params()[["base"]]
filtered_params <- base_params[sapply(base_params, function(params) {
params$id %in% "secondary"
})][[1]]
filtered_params$exclude <- input$primary
create_input_element(
input_id = "secondary",
ns = ns,
params = append_list(data(), filtered_params, "data")
)
})
output$tertiary <- shiny::renderUI({
shiny::req(input$type)
# Get the plot function name
base_params <- rv$plot.params()[["base"]]
filtered_params <- base_params[sapply(base_params, function(params) {
params$id %in% "tertiary"
})][[1]]
filtered_params$exclude <- c(input$primary, input$secondary)
create_input_element(
input_id = "tertiary",
ns = ns,
params = append_list(data(), filtered_params, "data")
)
})
### Generating additional parameter inputs if any specified
output$basic_parameters <- renderUI({
req(input$type, rv$plot.params)
# Get the plot function name
base_params <- rv$plot.params()[["basic"]]
base_params <- rv$plot.params()[["base"]]
params2update <- seq_along(base_params)[sapply(base_params, function(params) {
params$type %in% "select_variables"
filtered_params <- base_params[sapply(base_params, function(params) {
!params$id %in% c("secondary", "tertiary")
})]
# browser()
updated_params <- seq_along(params2update) |> lapply(function(index){
params <- base_params[params2update][[index]]
params$exclude <- input$primary
edits <- base_params[params2update][seq_len(index-1)]
id_exclude <- unlist(lapply(edits,\(.x){.x[["id"]]}))
if (length(id_exclude)>0){
ids <- paste0("base_", id_exclude)
params$exclude <- c(params$exclude, names(input)[ids %in% names(input)])
}
return(params)
})
base_params[params2update] <- updated_params
# Create UI elements for base parameters
base_inputs <- lapply(base_params, function(params) {
base_inputs <- lapply(filtered_params, function(params) {
input_id <- paste0("base_", params$id)
params$id <- NULL
if (params$type %in% "select_variables") {
@ -244,79 +267,10 @@ data_visuals_server <- function(id,
create_input_element(params, ns, input_id)
})
if(length(base_inputs) > 0) {
tagList(base_inputs)
} else {
p("No basic parameters available for this plot type.")
}
})
# output$secondary <- shiny::renderUI({
# shiny::req(input$type)
#
# browser()
#
#
# params <- rv$plot.params()[["inputs"]][[1]]
#
# # params$fun <- NULL
# params$exclude <- input$primary
# # params$inputId <- paste0("base_", names(available_plots()[[1]][["inputs"]])[1])
#
# # input_fun <- rlang::eval_tidy(rlang::sym("selectPlotVariables"), env = asNamespace("shiny"))
# #
# # rlang::inject(input_fun(!!!append_list(data(), params, "data")))
#
# create_input_element(input_id = paste0("base_", names(available_plots()[[1]][["inputs"]])[1]),
# ns = ns,
# params = append_list(data(), params, "data"))
#
# # rlang::exec(selectPlotVariables,
# # !!!append_list(data(), params, "data"))
#
#
# # cols <- c(rv$plot.params()[["secondary.extra"]], all_but(colnames(
# # subset_types(data(), rv$plot.params()[["secondary.type"]])
# # ), input$primary))
# #
# # columnSelectInput(
# # inputId = ns("secondary"),
# # data = data,
# # selected = cols[1],
# # placeholder = i18n$t("Please select"),
# # label = if (isTRUE(rv$plot.params()[["secondary.multi"]]))
# # i18n$t("Additional variables")
# # else
# # i18n$t("Secondary variable"),
# # multiple = rv$plot.params()[["secondary.multi"]],
# # maxItems = rv$plot.params()[["secondary.max"]],
# # col_subset = cols,
# # none_label = i18n$t("No variable")
# # )
# })
#
# output$tertiary <- shiny::renderUI({
# shiny::req(input$type)
# columnSelectInput(
# inputId = ns("tertiary"),
# data = data,
# placeholder = i18n$t("Please select"),
# label = i18n$t("Grouping variable"),
# multiple = FALSE,
# col_subset = c(
# "none",
# all_but(
# colnames(subset_types(data(), rv$plot.params()[["tertiary.type"]])),
# input$primary,
# input$secondary
# )
# ),
# none_label = i18n$t("No stratification")
# )
# })
### Color option
output$color_palette <- shiny::renderUI({
# shiny::req(input$type)
@ -331,25 +285,32 @@ data_visuals_server <- function(id,
shiny::observeEvent(input$act_plot, {
if (NROW(data()) > 0) {
tryCatch({
## BELOW NEEDS REVISION ###
# Get all input values with prefixes
base_inputs <- reactiveValuesToList(input)[grep("^base_", names(reactiveValuesToList(input)))]
advanced_inputs <- reactiveValuesToList(input)[grep("^advanced_", names(reactiveValuesToList(input)))]
# advanced_inputs <- reactiveValuesToList(input)[grep("^advanced_", names(reactiveValuesToList(input)))]
# Remove the prefix from names
names(base_inputs) <- gsub("^base_", "", names(base_inputs))
names(advanced_inputs) <- gsub("^advanced_", "", names(advanced_inputs))
# names(advanced_inputs) <- gsub("^advanced_", "", names(advanced_inputs))
# Combine all parameters
dynamic_params <- c(base_inputs, advanced_inputs)
base_inputs <- c(base_inputs,
list(color.palette = input$color_palette))
# If any of the specified parameters are NULL/missing, the settings
# accordion/panel was never opened, and they can be ignored, as
# default settings will the be used.
if (any(sapply(base_inputs, is.null))) {
dynamic_params <- list()
} else {
dynamic_params <- base_inputs
}
# Build parameters for plotting function
parameters <- list(
type = rv$plot.params()[["fun"]],
pri = input$primary,
color.palette = input$color_palette
sec = input$secondary,
ter = input$tertiary
)
parameters <- modifyList(parameters, dynamic_params)
@ -357,7 +318,15 @@ data_visuals_server <- function(id,
## If the dictionary holds additional arguments to pass to the
## plotting function, these are included
if (!is.null(rv$plot.params()[["fun.args"]])) {
parameters <- modifyList(parameters, rv$plot.params()[["fun.args"]])
default_params <- rv$plot.params()[["fun.args"]]
## Ensure not to overwrite user defined parameters are overwritten
## This allows to define default parameters.
##
## This will create a strange edge case, where the plot looks in
## one way, when plotted initially, but may change, when the settings
## accordion is opened. Problem for future me. Really mostly an edge case.
parameters <- modifyList(parameters, default_params[!names(default_params) %in% names(parameters)])
}
shiny::withProgress(message = i18n$t("Drawing the plot. Hold tight for a moment.."),
@ -437,642 +406,3 @@ data_visuals_server <- function(id,
}
)
}
available_plots <- function() {
list(
plot_bar_rel = list(
fun = "plot_bar",
fun.args = list(style = "fill"),
descr = i18n$t("Stacked relative barplot"),
note = i18n$t(
"Create relative stacked barplots to show the distribution of categorical levels"
),
primary.type = c("dichotomous", "categorical"),
### Input definitions ###
basic = list(
list(
id = "sec",
type = "select_variables",
var_types = c("dichotomous", "categorical"),
allow_none = FALSE,
# inputId = "sec",
label = i18n$t("Additional variables"),
multiple = FALSE
),
list(
id = "ter",
type = "select_variables",
var_types = c("dichotomous", "categorical"),
# inputId = "sec",
label = i18n$t("Grouping variable"),
multiple = FALSE
)
),
advanced = list()
#########
),
plot_violin = list(
fun = "plot_violin",
descr = i18n$t("Violin plot"),
note = i18n$t(
"A modern alternative to the classic boxplot to visualise data distribution"
),
primary.type = c("datatime", "continuous"),
### Input definitions ###
basic = list(
list(
id = "sec",
type = "select_variables",
var_types = c("dichotomous", "categorical"),
allow_none = TRUE,
# inputId = "sec",
label = i18n$t("Additional variables"),
multiple = FALSE
),
list(
id = "ter",
type = "select_variables",
var_types = c("dichotomous", "categorical"),
# inputId = "sec",
label = i18n$t("Grouping variable"),
multiple = FALSE
)
),
advanced = list()
#########
)
)
}
# Helper function to create input elements dynamically
create_input_element <- function(params, ns, input_id) {
# Add the namespaced inputId to the arguments
params$inputId <- ns(input_id)
# Map input types to Shiny functions
input_function <- switch(params$type,
"numeric_input" = shiny::numericInput,
"select_input" = shiny::selectInput,
"checkbox_input" = shiny::checkboxInput,
"slider_input" = shiny::sliderInput,
"text_input" = shiny::textInput,
"select_variables" = selectPlotVariables
)
params$type <- NULL
# Call the function with all arguments
do.call(input_function, params)
}
selectPlotVariables <- function(data,exclude=NULL,allow_none=TRUE,var_types,...){
datar <- if (is.reactive(data)){
data
} else {
reactive(data)}
cols <- all_but(colnames(
subset_types(datar(), var_types)
), exclude)
if (isTRUE(allow_none)){
cols <- c("none",cols)
}
params <- list(...)
params$none_label <- i18n$t("No variable")
params$col_subset <- cols
rlang::exec(columnSelectInput,
!!!append_list(datar(), params, "data"))
}
#' Select all from vector but
#'
#' @param data vector
#' @param ... exclude
#'
#' @returns vector
#' @export
#'
#' @examples
#' all_but(1:10, c(2, 3), 11, 5)
all_but <- function(data, ...) {
data[!data %in% c(...)]
}
#' Easily subset by data type function
#'
#' @param data data
#' @param types desired types
#' @param type.fun function to get type. Default is outcome_type
#'
#' @returns vector
#' @export
#'
#' @examples
#' default_parsing(mtcars) |> subset_types("ordinal")
#' default_parsing(mtcars) |> subset_types(c("dichotomous", "categorical"))
#' #' default_parsing(mtcars) |> subset_types("factor",class)
subset_types <- function(data, types, type.fun = data_type) {
data[sapply(data, type.fun) %in% types]
}
#' Implemented functions
#'
#' @description
#' Library of supported functions. The list name and "descr" element should be
#' unique for each element on list.
#'
#' - descr: Plot description
#'
#' - primary.type: Primary variable data type (continuous, dichotomous or ordinal)
#'
#' - secondary.type: Secondary variable data type (continuous, dichotomous or ordinal)
#'
#' - secondary.extra: "none" or NULL to have option to choose none.
#'
#' - tertiary.type: Tertiary variable data type (continuous, dichotomous or ordinal)
#'
#'
#' @returns list
#' @export
#'
#' @examples
#' supported_plots() |> str()
supported_plots <- function() {
list(
plot_bar_rel = list(
fun = "plot_bar",
fun.args = list(style = "fill"),
descr = i18n$t("Stacked relative barplot"),
note = i18n$t(
"Create relative stacked barplots to show the distribution of categorical levels"
),
primary.type = c("dichotomous", "categorical"),
secondary.type = c("dichotomous", "categorical"),
secondary.multi = FALSE,
tertiary.type = c("dichotomous", "categorical"),
secondary.extra = NULL
),
plot_bar_abs = list(
fun = "plot_bar",
fun.args = list(style = "dodge"),
descr = i18n$t("Side-by-side barplot"),
note = i18n$t(
"Create side-by-side barplot to show the distribution of categorical levels"
),
primary.type = c("dichotomous", "categorical"),
secondary.type = c("dichotomous", "categorical"),
secondary.multi = FALSE,
tertiary.type = c("dichotomous", "categorical"),
secondary.extra = "none"
),
plot_hbars = list(
fun = "plot_hbars",
descr = i18n$t("Stacked horizontal bars"),
note = i18n$t(
"A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars"
),
primary.type = c("dichotomous", "categorical"),
secondary.type = c("dichotomous", "categorical"),
secondary.multi = FALSE,
tertiary.type = c("dichotomous", "categorical"),
secondary.extra = "none"
),
plot_violin = list(
fun = "plot_violin",
descr = i18n$t("Violin plot"),
note = i18n$t(
"A modern alternative to the classic boxplot to visualise data distribution"
),
primary.type = c("datatime", "continuous"),
secondary.type = c("dichotomous", "categorical"),
secondary.multi = FALSE,
secondary.extra = "none",
tertiary.type = c("dichotomous", "categorical")
),
# plot_ridge = list(
# descr = "Ridge plot",
# note = "An alternative option to visualise data distribution",
# primary.type = "continuous",
# secondary.type = c("dichotomous" ,"categorical"),
# tertiary.type = c("dichotomous" ,"categorical"),
# secondary.extra = NULL
# ),
plot_sankey = list(
fun = "plot_sankey",
descr = i18n$t("Sankey plot"),
note = i18n$t("A way of visualising change between groups"),
primary.type = c("dichotomous", "categorical"),
secondary.type = c("dichotomous", "categorical"),
secondary.multi = FALSE,
secondary.extra = NULL,
tertiary.type = c("dichotomous", "categorical")
),
plot_scatter = list(
fun = "plot_scatter",
descr = i18n$t("Scatter plot"),
note = i18n$t("A classic way of showing the association between to variables"),
primary.type = c("datatime", "continuous"),
secondary.type = c("datatime", "continuous", "categorical"),
secondary.multi = FALSE,
tertiary.type = c("dichotomous", "categorical"),
secondary.extra = NULL
),
plot_box = list(
fun = "plot_box",
descr = i18n$t("Box plot"),
note = i18n$t("A classic way to plot data distribution by groups"),
primary.type = c("datatime", "continuous"),
secondary.type = c("dichotomous", "categorical"),
secondary.multi = FALSE,
tertiary.type = c("dichotomous", "categorical"),
secondary.extra = "none"
),
plot_euler = list(
fun = "plot_euler",
descr = i18n$t("Euler diagram"),
note = i18n$t(
"Generate area-proportional Euler diagrams to display set relationships"
),
primary.type = c("dichotomous"),
secondary.type = c("dichotomous"),
secondary.multi = TRUE,
secondary.max = 4,
tertiary.type = c("dichotomous"),
secondary.extra = NULL
),
plot_euler = list(
fun = "plot_likert",
descr = i18n$t("Likert diagram"),
note = i18n$t(
"Plot survey results"
),
primary.type = c("dichotomous", "categorical"),
secondary.type = c("dichotomous", "categorical"),
secondary.multi = TRUE,
secondary.extra = NULL,
tertiary.type = c("dichotomous", "categorical"),
secondary.extra = NULL
)
)
}
#' Get possible regression models
#'
#' @param data data
#'
#' @returns character vector
#' @export
#'
#' @examples
#' mtcars |>
#' default_parsing() |>
#' dplyr::pull("cyl") |>
#' possible_plots()
#'
#' mtcars |>
#' default_parsing() |>
#' dplyr::select("mpg") |>
#' possible_plots()
possible_plots <- function(data,source_list = supported_plots()) {
# browser()
# data <- if (is.reactive(data)) data() else data
if (is.data.frame(data)) {
data <- data[[1]]
}
type <- data_type(data)
if (type == "unknown") {
out <- type
} else {
out <- source_list |>
lapply(\(.x) {
if (type %in% .x$primary.type) {
.x$descr
}
}) |>
unlist()
}
unname(out)
}
#' Get the function options based on the selected function description
#'
#' @param data vector
#'
#' @returns list
#' @export
#'
#' @examples
#' ls <- mtcars |>
#' default_parsing() |>
#' dplyr::pull(mpg) |>
#' possible_plots() |>
#' (\(.x){
#' .x[[1]]
#' })() |>
#' get_plot_options()
get_plot_options <- function(data) {
descrs <- supported_plots() |>
lapply(\(.x) {
.x$descr
}) |>
unlist()
supported_plots() |>
(\(.x) {
.x[match(data, descrs)]
})()
}
#' Get the function parameters based on the selected function description
#'
#' @param data vector
#'
#' @returns list
#' @export
#'
#' @examples
#' ls <- mtcars |>
#' default_parsing() |>
#' dplyr::pull(mpg) |>
#' possible_plots() |>
#' (\(.x){
#' .x[[1]]
#' })() |>
#' get_input_params()
get_input_params <- function(data) {
descr <- available_plots() |>
lapply(\(.x) {
.x$descr
}) |>
unlist()
available_plots() |>
(\(.x) {
.x[match(data, descr)]
})()
}
#' Wrapper to create plot based on provided type
#'
#' @param data data.frame
#' @param pri primary variable
#' @param sec secondary variable
#' @param ter tertiary variable
#' @param type plot type (derived from possible_plots() and matches custom function)
#' @param color.palette choose color palette. See \code{\link{plot_colors}} for support.
#' @param ... ignored for now
#'
#' @name data-plots
#'
#' @returns ggplot2 object
#' @export
#'
#' @examples
#' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes()
create_plot <- function(data,
type,
pri,
sec,
ter = NULL,
color.palette = "viridis",
...) {
if (!is.null(sec)) {
if (!any(sec %in% names(data))) {
sec <- NULL
}
}
if (!is.null(ter)) {
if (!ter %in% names(data)) {
ter <- NULL
}
}
parameters <- list(
pri = pri,
sec = sec,
ter = ter,
color.palette = color.palette,
...
)
out <- do.call(type, modifyList(parameters, list(data = data)))
code <- rlang::call2(type, !!!parameters, .ns = "FreesearchR")
attr(out, "code") <- code
out
}
#' Print label, and if missing print variable name for plots
#'
#' @param data vector or data frame
#' @param var variable name. Optional.
#'
#' @returns character string
#' @export
#'
#' @examples
#' mtcars |> get_label(var = "mpg")
#' mtcars |> get_label()
#' mtcars$mpg |> get_label()
#' gtsummary::trial |> get_label(var = "trt")
#' gtsummary::trial$trt |> get_label()
#' 1:10 |> get_label()
get_label <- function(data, var = NULL) {
# data <- if (is.reactive(data)) data() else data
if (!is.null(var) & is.data.frame(data)) {
data <- data[[var]]
}
out <- REDCapCAST::get_attr(data = data, attr = "label")
if (is.na(out)) {
if (is.null(var)) {
out <- deparse(substitute(data))
} else {
if (is.symbol(var)) {
out <- gsub('\"', "", deparse(substitute(var)))
} else {
out <- var
}
}
}
out
}
#' Line breaking at given number of characters for nicely plotting labels
#'
#' @param data string
#' @param lineLength maximum line length
#' @param fixed flag to force split at exactly the value given in lineLength.
#' Default is FALSE, only splitting at spaces.
#'
#' @returns character string
#' @export
#'
#' @examples
#' "Lorem ipsum... you know the routine" |> line_break()
#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE)
line_break <- function(data,
lineLength = 20,
force = FALSE) {
if (isTRUE(force)) {
## This eats some letters when splitting a sentence... ??
gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"),
"\\1\n",
data)
} else {
paste(strwrap(data, lineLength), collapse = "\n")
}
## https://stackoverflow.com/a/29847221
}
#' Wrapping
#'
#' @param data list of ggplot2 objects
#' @param tag_levels passed to patchwork::plot_annotation if given. Default is NULL
#' @param title panel title
#' @param guides passed to patchwork::wrap_plots()
#' @param axes passed to patchwork::wrap_plots()
#' @param axis_titles passed to patchwork::wrap_plots()
#' @param ... passed to patchwork::wrap_plots()
#'
#' @returns list of ggplot2 objects
#' @export
#'
wrap_plot_list <- function(data,
tag_levels = NULL,
title = NULL,
axis.font.family = NULL,
guides = "collect",
axes = "collect",
axis_titles = "collect",
y.axis.percentage = FALSE,
...) {
if (ggplot2::is_ggplot(data[[1]])) {
if (length(data) > 1) {
out <- data |>
(\(.x) {
if (rlang::is_named(.x)) {
purrr::imap(.x, \(.y, .i) {
.y + ggplot2::ggtitle(.i)
})
} else {
.x
}
})() |>
align_axes(percentage=y.axis.percentage) |>
patchwork::wrap_plots(guides = guides,
axes = axes,
axis_titles = axis_titles,
...)
if (!is.null(tag_levels)) {
out <- out + patchwork::plot_annotation(tag_levels = tag_levels)
}
if (!is.null(title)) {
out <- out +
patchwork::plot_annotation(
title = title,
theme = ggplot2::theme(plot.title = ggplot2::element_text(size = 25))
)
}
} else {
out <- data[[1]]
}
} else {
cli::cli_abort("Can only wrap lists of {.cls ggplot} objects")
}
if (!is.null(axis.font.family)) {
if (inherits(x = out, what = "patchwork")) {
out <- out &
ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family))
} else {
out <- out +
ggplot2::theme(axis.text = ggplot2::element_text(family = axis.font.family))
}
}
out
}
#' Aligns axes between plots
#'
#' @param ... ggplot2 objects or list of ggplot2 objects
#'
#' @returns list of ggplot2 objects
#' @export
#'
align_axes <- function(...,
x.axis = TRUE,
y.axis = TRUE,
percentage = FALSE) {
# https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object
# https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150
if (ggplot2::is_ggplot(..1)) {
## Assumes list of ggplots
p <- list(...)
} else if (is.list(..1)) {
## Assumes list with list of ggplots
p <- ..1
} else {
cli::cli_abort("Can only align {.cls ggplot} objects or a list of them")
}
yr <- clean_common_axis(p, "y")
xr <- clean_common_axis(p, "x")
suppressWarnings({
p_out <- purrr::map(p, \(.x) {
out <- .x
if (isTRUE(x.axis)) {
out <- out + ggplot2::xlim(xr)
}
if (isTRUE(y.axis)) {
out <- out + ggplot2::ylim(yr)
}
out
})
})
if(isTRUE(percentage)){
lapply(p_out,\(.x){
.x+
ggplot2::scale_y_continuous(labels = scales::percent)
})
} else {
p_out
}
}
#' Extract and clean axis ranges
#'
#' @param p plot
#' @param axis axis. x or y.
#'
#' @returns vector
#' @export
#'
clean_common_axis <- function(p, axis) {
purrr::map(p, ~ ggplot2::layer_scales(.x)[[axis]]$get_limits()) |>
unlist() |>
(\(.x) {
if (is.numeric(.x)) {
range(.x)
} else {
as.character(.x)
}
})() |>
unique()
}