mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2026-06-19 04:27:30 +02:00
transformed for a new pragmatic compromise to dynamically load additional input options where available
This commit is contained in:
parent
f2a522dcb6
commit
f774b90d07
1 changed files with 105 additions and 775 deletions
858
R/data_plots.R
858
R/data_plots.R
|
|
@ -14,12 +14,23 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) {
|
||||||
list(
|
list(
|
||||||
bslib::layout_sidebar(
|
bslib::layout_sidebar(
|
||||||
sidebar = bslib::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(
|
bslib::accordion(
|
||||||
id = "acc_plot",
|
id = "acc_plot",
|
||||||
multiple = FALSE,
|
multiple = FALSE,
|
||||||
bslib::accordion_panel(
|
bslib::accordion_panel(
|
||||||
value = "acc_pan_plot",
|
value = "acc_pan_plot",
|
||||||
title = "Create plot",
|
title = i18n$t("Define plot"),
|
||||||
icon = phosphoricons::ph("chart-line"),
|
icon = phosphoricons::ph("chart-line"),
|
||||||
# icon = bsicons::bs_icon("graph-up"),
|
# icon = bsicons::bs_icon("graph-up"),
|
||||||
shiny::uiOutput(outputId = ns("primary")),
|
shiny::uiOutput(outputId = ns("primary")),
|
||||||
|
|
@ -30,20 +41,15 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) {
|
||||||
),
|
),
|
||||||
shiny::tags$br(),
|
shiny::tags$br(),
|
||||||
shiny::uiOutput(outputId = ns("type")),
|
shiny::uiOutput(outputId = ns("type")),
|
||||||
shiny::uiOutput(outputId = ns("basic_parameters")),
|
shiny::uiOutput(outputId = ns("secondary")),
|
||||||
# shiny::uiOutput(outputId = ns("secondary")),
|
shiny::uiOutput(outputId = ns("tertiary"))
|
||||||
# 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::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(
|
bslib::accordion_panel(
|
||||||
value = "acc_pan_download",
|
value = "acc_pan_download",
|
||||||
|
|
@ -120,10 +126,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) {
|
||||||
#' @name data-plots
|
#' @name data-plots
|
||||||
#' @returns shiny server module
|
#' @returns shiny server module
|
||||||
#' @export
|
#' @export
|
||||||
data_visuals_server <- function(id,
|
data_visuals_server <- function(id, data, palettes = color_choices(), ...) {
|
||||||
data,
|
|
||||||
palettes,
|
|
||||||
...) {
|
|
||||||
shiny::moduleServer(
|
shiny::moduleServer(
|
||||||
id = id,
|
id = id,
|
||||||
module = function(input, output, session) {
|
module = function(input, output, session) {
|
||||||
|
|
@ -175,8 +178,7 @@ data_visuals_server <- function(id,
|
||||||
plot_data <- data()[input$primary]
|
plot_data <- data()[input$primary]
|
||||||
}
|
}
|
||||||
|
|
||||||
plots <- possible_plots(data = plot_data,
|
plots <- possible_plots(data = plot_data, source_list = available_plots())
|
||||||
source_list=available_plots())
|
|
||||||
|
|
||||||
plots_named <- get_input_params(plots) |>
|
plots_named <- get_input_params(plots) |>
|
||||||
lapply(\(.x) {
|
lapply(\(.x) {
|
||||||
|
|
@ -198,125 +200,77 @@ data_visuals_server <- function(id,
|
||||||
})
|
})
|
||||||
|
|
||||||
rv$plot.params <- shiny::reactive({
|
rv$plot.params <- shiny::reactive({
|
||||||
get_input_params(input$type)|> purrr::pluck(1)
|
get_input_params(input$type) |> purrr::pluck(1)
|
||||||
# get_plot_options(input$type) |> purrr::pluck(1)
|
# get_plot_options(input$type) |> purrr::pluck(1)
|
||||||
})
|
})
|
||||||
|
|
||||||
|
|
||||||
|
### 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({
|
output$basic_parameters <- renderUI({
|
||||||
req(input$type, rv$plot.params)
|
req(input$type, rv$plot.params)
|
||||||
|
|
||||||
# Get the plot function name
|
# Get the plot function name
|
||||||
base_params <- rv$plot.params()[["basic"]]
|
base_params <- rv$plot.params()[["base"]]
|
||||||
|
|
||||||
|
filtered_params <- base_params[sapply(base_params, function(params) {
|
||||||
params2update <- seq_along(base_params)[sapply(base_params, function(params) {
|
!params$id %in% c("secondary", "tertiary")
|
||||||
params$type %in% "select_variables"
|
|
||||||
})]
|
})]
|
||||||
|
|
||||||
# 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
|
# 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)
|
input_id <- paste0("base_", params$id)
|
||||||
params$id <- NULL
|
params$id <- NULL
|
||||||
if (params$type %in% "select_variables"){
|
if (params$type %in% "select_variables") {
|
||||||
params$data <- data()
|
params$data <- data()
|
||||||
}
|
}
|
||||||
|
|
||||||
create_input_element(params, ns, input_id)
|
create_input_element(params, ns, input_id)
|
||||||
})
|
})
|
||||||
|
|
||||||
if(length(base_inputs) > 0) {
|
|
||||||
tagList(base_inputs)
|
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
|
### Color option
|
||||||
output$color_palette <- shiny::renderUI({
|
output$color_palette <- shiny::renderUI({
|
||||||
# shiny::req(input$type)
|
# shiny::req(input$type)
|
||||||
|
|
@ -331,25 +285,32 @@ data_visuals_server <- function(id,
|
||||||
shiny::observeEvent(input$act_plot, {
|
shiny::observeEvent(input$act_plot, {
|
||||||
if (NROW(data()) > 0) {
|
if (NROW(data()) > 0) {
|
||||||
tryCatch({
|
tryCatch({
|
||||||
|
|
||||||
## BELOW NEEDS REVISION ###
|
|
||||||
|
|
||||||
# Get all input values with prefixes
|
# Get all input values with prefixes
|
||||||
base_inputs <- reactiveValuesToList(input)[grep("^base_", names(reactiveValuesToList(input)))]
|
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
|
# Remove the prefix from names
|
||||||
names(base_inputs) <- gsub("^base_", "", names(base_inputs))
|
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
|
base_inputs <- c(base_inputs,
|
||||||
dynamic_params <- c(base_inputs, advanced_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
|
# Build parameters for plotting function
|
||||||
parameters <- list(
|
parameters <- list(
|
||||||
type = rv$plot.params()[["fun"]],
|
type = rv$plot.params()[["fun"]],
|
||||||
pri = input$primary,
|
pri = input$primary,
|
||||||
color.palette = input$color_palette
|
sec = input$secondary,
|
||||||
|
ter = input$tertiary
|
||||||
)
|
)
|
||||||
|
|
||||||
parameters <- modifyList(parameters, dynamic_params)
|
parameters <- modifyList(parameters, dynamic_params)
|
||||||
|
|
@ -357,7 +318,15 @@ data_visuals_server <- function(id,
|
||||||
## If the dictionary holds additional arguments to pass to the
|
## If the dictionary holds additional arguments to pass to the
|
||||||
## plotting function, these are included
|
## plotting function, these are included
|
||||||
if (!is.null(rv$plot.params()[["fun.args"]])) {
|
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.."),
|
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()
|
|
||||||
}
|
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue