diff --git a/DESCRIPTION b/DESCRIPTION index 69564bc2..cc854ec0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: FreesearchR Title: Easy data analysis for clinicians -Version: 26.4.2 +Version: 26.6.1 Authors@R: c( person("Andreas Gammelgaard", "Damsbo",email="agdamsbo@clin.au.dk", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-7559-1154")), @@ -118,6 +118,7 @@ Collate: 'launch_FreesearchR.R' 'missings-module.R' 'plot-download-module.R' + 'plot-helpers.R' 'plot_bar.R' 'plot_box.R' 'plot_euler.R' diff --git a/NAMESPACE b/NAMESPACE index 9e036c3f..947b97e8 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -16,6 +16,7 @@ export(append_column) export(append_list) export(apply_labels) export(argsstring2list) +export(available_plots) export(baseline_table) export(class_icons) export(clean_common_axis) @@ -64,6 +65,7 @@ export(format_writer) export(generate_colors) export(get_data_packages) export(get_fun_options) +export(get_input_params) export(get_label) export(get_list_elements) export(get_plot_options) diff --git a/NEWS.md b/NEWS.md index 785ee46a..ce86f7a7 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,7 @@ +# FreesearchR 26.6.1 + +*NEW* The visuals module has been restructured to allow for more advanced inputs, which will be added in the future. Basically a more future proof design allowing for more adjustments, while striving to keep the simplicity. Have fun! + # FreesearchR 26.4.2 Bug fixes and revised color choices. diff --git a/R/app_version.R b/R/app_version.R index 2cbd2cc4..bce90462 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'26.4.2' +app_version <- function()'26.6.1' diff --git a/R/data_plots.R b/R/data_plots.R index a01403df..b9e84c85 100644 --- a/R/data_plots.R +++ b/R/data_plots.R @@ -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,19 +41,16 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { ), shiny::tags$br(), shiny::uiOutput(outputId = ns("type")), + shiny::h5(i18n$t("Other variables")), shiny::uiOutput(outputId = ns("secondary")), - shiny::uiOutput(outputId = ns("tertiary")), + shiny::uiOutput(outputId = ns("tertiary")) + ), + bslib::accordion_panel( + value = "acc_pan_params", + title = i18n$t("Settings"), + icon = phosphoricons::ph("gear"), 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".')) + shiny::uiOutput(outputId = ns("basic_parameters")), ), bslib::accordion_panel( value = "acc_pan_download", @@ -95,14 +103,14 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { shiny::p( "We have collected a few notes on visualising data and details on the options included in FreesearchR:", shiny::tags$a( - href = "https://agdamsbo.github.io/FreesearchR/articles/visuals.html", + href = "https://freesearchr.github.io/FreesearchR-knowledge/app/visuals.html", "View notes in new tab", target = "_blank", rel = "noopener noreferrer" ) ) ), - shiny::plotOutput(ns("plot"), height = "70vh"), + shiny::plotOutput(ns("plot"), height = "65vh"), shiny::tags$br(), shiny::tags$br(), shiny::htmlOutput(outputId = ns("code_plot")) @@ -119,10 +127,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) { @@ -174,69 +179,99 @@ data_visuals_server <- function(id, plot_data <- data()[input$primary] } - plots <- possible_plots(data = plot_data) + plots <- possible_plots(data = plot_data, source_list = available_plots()) - plots_named <- get_plot_options(plots) |> + plots_named <- get_input_params(plots) |> lapply(\(.x) { stats::setNames(.x$descr, .x$note) }) + # plots_named <- get_plot_options(plots) |> + # lapply(\(.x) { + # stats::setNames(.x$descr, .x$note) + # }) + vectorSelectInput( inputId = ns("type"), selected = NULL, - label = shiny::h4(i18n$t("Plot type")), + label = shiny::h5(i18n$t("Plot type")), choices = Reduce(c, plots_named), multiple = FALSE ) }) rv$plot.params <- shiny::reactive({ - get_plot_options(input$type) |> purrr::pluck(1) + get_input_params(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) - cols <- c(rv$plot.params()[["secondary.extra"]], all_but(colnames( - subset_types(data(), rv$plot.params()[["secondary.type"]]) - ), input$primary)) + # Get the plot function name + base_params <- rv$plot.params()[["base"]] - 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") + 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) - 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") + # 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()[["base"]] + + filtered_params <- base_params[sapply(base_params, function(params) { + !params$id %in% c("secondary", "tertiary") + })] + + + # Create UI elements for base parameters + base_inputs <- lapply(filtered_params, function(params) { + input_id <- paste0("base_", params$id) + params$id <- NULL + if (params$type %in% "select_variables") { + params$data <- data() + } + + create_input_element(params, ns, input_id) + }) + tagList(base_inputs) + + }) + ### Color option output$color_palette <- shiny::renderUI({ # shiny::req(input$type) @@ -250,19 +285,49 @@ data_visuals_server <- function(id, shiny::observeEvent(input$act_plot, { if (NROW(data()) > 0) { - tryCatch({ + tryCatch({ + # Get all input values with prefixes + base_inputs <- reactiveValuesToList(input)[grep("^base_", 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)) + + 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, sec = input$secondary, - ter = input$tertiary, - color.palette = input$color_palette + ter = input$tertiary ) + parameters <- modifyList(parameters, dynamic_params) + ## 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.."), @@ -298,7 +363,25 @@ data_visuals_server <- function(id, if (!is.null(rv$plot)) { rv$plot } else { - return(NULL) + # Create a placeholder plot with instructions using ggplot2 + ggplot2::ggplot() + + ggplot2::annotate( + "text", + x = 0.5, + y = 0.5, + label = i18n$t("Select variables and plot type,\nthen click 'Plot' to generate visualization"), + size = 5, + color = "gray50", + lineheight = 0.8 + ) + + ggplot2::xlim(0, 1) + + ggplot2::ylim(0, 1) + + ggplot2::theme_void() + + ggplot2::theme( + panel.background = ggplot2::element_rect(fill = "white"), + plot.background = ggplot2::element_rect(fill = "white") + ) + # return(NULL) } }) @@ -342,503 +425,3 @@ data_visuals_server <- function(id, } ) } - -#' 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) { - # 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 <- supported_plots() |> - 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)] - })() -} - - - -#' 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() -} diff --git a/R/hosted_version.R b/R/hosted_version.R index 33aaf67c..27a50899 100644 --- a/R/hosted_version.R +++ b/R/hosted_version.R @@ -1 +1 @@ -hosted_version <- function()'v26.4.2-260410' +hosted_version <- function()'v26.6.1' diff --git a/R/plot-helpers.R b/R/plot-helpers.R new file mode 100644 index 00000000..5b4ae981 --- /dev/null +++ b/R/plot-helpers.R @@ -0,0 +1,878 @@ +#' Implemented functions +#' +#' @description +#' Library of supported functions. The list name and "descr" element should be +#' unique for each element on list. +#' +#' - fun: the plotting function +#' +#' - fun.args: default parameters for the plotting function +#' +#' - descr: Plot description +#' +#' - note: Short note/description of the function for displaying in ui and docs +#' +#' - primary.type: Primary variable data type (see [data_type]) +#' +#' - base: holds a list of parameters for plot input fields generation +#' Secondary and tertiary variable input fields are mandatory. +#' +#' +#' @returns list +#' @export +#' +#' @examples +#' available_plots() |> str() +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 ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = FALSE, + # inputId = "sec", + label = i18n$t("Additional variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + 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"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = TRUE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + 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"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = TRUE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ), + list( + id = "reverse", + type = "select_input", + label = i18n$t("Reverse colors"), + choices = c(yes = TRUE, no = 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 ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = TRUE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + 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"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = FALSE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + 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"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("datatime", "continuous", "categorical"), + allow_none = FALSE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + 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"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = TRUE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = FALSE + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + 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"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous"), + allow_none = FALSE, + # inputId = "sec", + label = i18n$t("Secondary variable"), + multiple = TRUE, + maxItems = 4 + ), + list( + id = "tertiary", + type = "select_variables", + var_types = c("dichotomous"), + # inputId = "sec", + label = i18n$t("Grouping variable"), + multiple = FALSE + ) + ), + advanced = list() + ######### + ), + plot_likert = list( + fun = "plot_likert", + descr = i18n$t("Likert diagram"), + note = i18n$t("Plot survey results"), + primary.type = c("dichotomous", "categorical"), + ### Input definitions ### + base = list( + list( + id = "secondary", + type = "select_variables", + var_types = c("dichotomous", "categorical"), + allow_none = TRUE, + # inputId = "sec", + label = i18n$t("Additional variables"), + multiple = TRUE + ), + list( + id = "tertiary", + 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 + params$id <- NULL + + + # Call the function with all arguments + do.call(input_function, params) +} + +#' Wrapper for columnSelectInput +#' +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_likert = 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() +} diff --git a/R/plot_bar.R b/R/plot_bar.R index 0535b6f3..e9879ef3 100644 --- a/R/plot_bar.R +++ b/R/plot_bar.R @@ -39,14 +39,14 @@ plot_bar <- function(data, sec = sec, style = style, max_level = max_level, - color.palette = color.palette + color.palette = color.palette, + ... ) }) wrap_plot_list(out, title = glue::glue(i18n$t("Grouped by {get_label(data,ter)}")), - y.axis.percentage = TRUE, - ...) + y.axis.percentage = TRUE) } diff --git a/R/plot_box.R b/R/plot_box.R index 01911aac..4acd67ab 100644 --- a/R/plot_box.R +++ b/R/plot_box.R @@ -32,11 +32,11 @@ plot_box <- function(data, pri, sec, ter = NULL,color.palette="viridis",...) { data = .ds, pri = pri, sec = sec, - color.palette=color.palette + color.palette=color.palette, ... ) }) - wrap_plot_list(out,title=glue::glue(i18n$t("Grouped by {get_label(data,ter)}")),...) + wrap_plot_list(out,title=glue::glue(i18n$t("Grouped by {get_label(data,ter)}"))) } diff --git a/R/plot_euler.R b/R/plot_euler.R index 27cdf02f..a5a0d31f 100644 --- a/R/plot_euler.R +++ b/R/plot_euler.R @@ -131,7 +131,7 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103,color.palette="vi #' D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE) #' ) |> plot_euler_single() #' mtcars[c("vs", "am")] |> plot_euler_single("magma") -plot_euler_single <- function(data,color.palette="viridis") { +plot_euler_single <- function(data,color.palette="viridis", ...) { data |> ggeulerr(shape = "circle") + diff --git a/R/plot_hbar.R b/R/plot_hbar.R index d93ef4c9..fc33b20d 100644 --- a/R/plot_hbar.R +++ b/R/plot_hbar.R @@ -15,13 +15,15 @@ plot_hbars <- function(data, pri, sec, ter = NULL, - color.palette = "viridis") { + color.palette = "viridis", + ...) { vertical_stacked_bars( data = data, score = pri, group = sec, strata = ter, - color.palette = color.palette + color.palette = color.palette, + ... ) } @@ -74,7 +76,7 @@ vertical_stacked_bars <- function(data, colors <- generate_colors(n = nrow(df.table), palette = color.palette) ## Colors are reversed by default as that usually gives the best result - if (isTRUE(reverse)) { + if (isTRUE(reverse) | reverse=="TRUE") { colors <- rev(colors) } diff --git a/R/plot_likert.R b/R/plot_likert.R index c18c57a1..e33256a2 100644 --- a/R/plot_likert.R +++ b/R/plot_likert.R @@ -15,7 +15,8 @@ plot_likert <- function(data, pri, sec = NULL, ter = NULL, - color.palette = "viridis") { + color.palette = "viridis", + ...) { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { diff --git a/R/plot_sankey.R b/R/plot_sankey.R index 23c1a13a..409a1050 100644 --- a/R/plot_sankey.R +++ b/R/plot_sankey.R @@ -95,7 +95,8 @@ plot_sankey <- function(data, default.color = "#2986cc", box.color = "#1E4B66", na.color = "grey80", - missing.level = "Missing") { + missing.level = "Missing", + ...) { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { diff --git a/R/plot_scatter.R b/R/plot_scatter.R index 142c30fd..8c73547e 100644 --- a/R/plot_scatter.R +++ b/R/plot_scatter.R @@ -8,7 +8,7 @@ #' @examples #' mtcars |> plot_scatter(pri = "mpg", sec = "wt") #' mtcars |> plot_scatter(pri = "mpg", sec = "wt",ter="carb") -plot_scatter <- function(data, pri, sec, ter = NULL, color.palette="viridis") { +plot_scatter <- function(data, pri, sec, ter = NULL, color.palette="viridis", ...) { if (is.null(ter)) { rempsyc::nice_scatter( data = data, diff --git a/R/plot_violin.R b/R/plot_violin.R index 83d11d2a..29850d26 100644 --- a/R/plot_violin.R +++ b/R/plot_violin.R @@ -8,7 +8,7 @@ #' @examples #' mtcars |> plot_violin(pri = "mpg", sec = "cyl") #' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear", color.palette="Blues") -plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis") { +plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis", ...) { if (!is.null(ter)) { ds <- split(data, data[ter]) } else { @@ -23,7 +23,8 @@ plot_violin <- function(data, pri, sec, ter = NULL, color.palette="viridis") { group = sec, response = pri, xtitle = get_label(data, var = sec), - ytitle = get_label(data, var = pri) + ytitle = get_label(data, var = pri), + ... )+ scale_fill_generate(palette=color.palette) }) diff --git a/R/ui_elements.R b/R/ui_elements.R index 6686879d..b08d5152 100644 --- a/R/ui_elements.R +++ b/R/ui_elements.R @@ -247,7 +247,7 @@ ui_elements <- function(selection) { "Read more on how ", tags$a( "data types", - href = "https://agdamsbo.github.io/FreesearchR/articles/data-types.html", + href = "https://freesearchr.github.io/FreesearchR-knowledge/app/data_types.html", target = "_blank", rel = "noopener noreferrer" ), @@ -694,7 +694,7 @@ ui_elements <- function(selection) { "docs" = bslib::nav_item( # shiny::img(shiny::icon("book")), shiny::tags$a( - href = "https://agdamsbo.github.io/FreesearchR/", + href = "https://freesearchr.github.io/FreesearchR-knowledge/", "Docs", shiny::icon("arrow-up-right-from-square"), target = "_blank", diff --git a/examples/visuals_module_demo.R b/examples/visuals_module_demo.R index 00a8c020..e4883d6c 100644 --- a/examples/visuals_module_demo.R +++ b/examples/visuals_module_demo.R @@ -22,7 +22,7 @@ visuals_demo_app <- function() { ) ) server <- function(input, output, session) { - pl <- data_visuals_server("visuals", data = shiny::reactive(default_parsing(mtcars))) + pl <- data_visuals_server("visuals", data = shiny::reactive(default_parsing(mtcars)),palettes = color_choices()) } shiny::shinyApp(ui, server) } diff --git a/inst/translations/translation_da.csv b/inst/translations/translation_da.csv index 927131ba..8b230b1c 100644 --- a/inst/translations/translation_da.csv +++ b/inst/translations/translation_da.csv @@ -89,7 +89,6 @@ "and","og" "from each pair","fra hvert par" "Plot","Tegn" -"Adjust settings, then press ""Plot"".","Juster indstillingerne og tryk så ""Tegn""." "Plot height (mm)","Højde af grafik (mm)" "Plot width (mm)","Bredde af grafik (mm)" "File format","File format" @@ -97,12 +96,7 @@ "Select variable","Vælg variabel" "Response variable","Svarvariable" "Plot type","Type af grafik" -"Please select","Vælg" -"Additional variables","Yderligere variabler" -"Secondary variable","Sekundær variabel" "No variable","Ingen variabel" -"Grouping variable","Variabel til gruppering" -"No stratification","Ingen stratificering" "Drawing the plot. Hold tight for a moment..","Tegner grafikken. Spænd selen.." "#Plotting\n","#Tegner\n" "Stacked horizontal bars","Stablede horisontale søjler" @@ -310,7 +304,6 @@ "Sample data","Sample data" "Settings","Settings" "Create new factor","Create new factor" -"Choose color palette","Choose color palette" "Optional filter logic (e.g., ⁠[gender] = 'female')","Optional filter logic (e.g., ⁠[gender] = 'female')" "Drop empty","Drop empty" "Choose variable:","Choose variable:" @@ -320,3 +313,13 @@ "Modify factor","Modify factor" "Create factor/categorical variable from other variables.","Create factor/categorical variable from other variables." "The data set has %s obs. in %s variables.","The data set has %s obs. in %s variables." +"Adjust plot input and settings below, then press ""Plot"".","Adjust plot input and settings below, then press ""Plot""." +"Define plot","Define plot" +"Choose color palette","Choose color palette" +"Additional variable","Additional variable" +"Grouping variable","Grouping variable" +"Secondary variable","Secondary variable" +"Reverse colors","Reverse colors" +"Plot survey results","Plot survey results" +"Additional variables","Additional variables" +"Other variables","Other variables" diff --git a/inst/translations/translation_sw.csv b/inst/translations/translation_sw.csv index 134ec155..4b0d628a 100644 --- a/inst/translations/translation_sw.csv +++ b/inst/translations/translation_sw.csv @@ -89,7 +89,6 @@ "and","na" "from each pair","kutoka kwa kila jozi" "Plot","Kipande cha habari" -"Adjust settings, then press ""Plot"".","Rekebisha mipangilio, kisha bonyeza ""Plot""." "Plot height (mm)","Urefu wa kiwanja (mm)" "Plot width (mm)","Upana wa kiwanja (mm)" "File format","Umbizo la faili" @@ -97,12 +96,7 @@ "Select variable","Chagua kigezo" "Response variable","Kigezo cha majibu" "Plot type","Aina ya kiwanja" -"Please select","Tafadhali chagua" -"Additional variables","Vigezo vya ziada" -"Secondary variable","Kigezo cha pili" "No variable","Hakuna kigezo" -"Grouping variable","Kigezo cha kuweka katika makundi" -"No stratification","Hakuna matabaka" "Drawing the plot. Hold tight for a moment..","Kuchora njama. Shikilia kwa muda.." "#Plotting\n","#Upangaji\n" "Stacked horizontal bars","Pau za mlalo zilizopangwa kwa mpangilio" @@ -310,7 +304,6 @@ "Sample data","Sample data" "Settings","Settings" "Create new factor","Create new factor" -"Choose color palette","Choose color palette" "Optional filter logic (e.g., ⁠[gender] = 'female')","Optional filter logic (e.g., ⁠[gender] = 'female')" "Drop empty","Drop empty" "Choose variable:","Choose variable:" @@ -320,3 +313,13 @@ "Modify factor","Modify factor" "Create factor/categorical variable from other variables.","Create factor/categorical variable from other variables." "The data set has %s obs. in %s variables.","The data set has %s obs. in %s variables." +"Adjust plot input and settings below, then press ""Plot"".","Adjust plot input and settings below, then press ""Plot""." +"Define plot","Define plot" +"Choose color palette","Choose color palette" +"Additional variable","Additional variable" +"Grouping variable","Grouping variable" +"Secondary variable","Secondary variable" +"Reverse colors","Reverse colors" +"Plot survey results","Plot survey results" +"Additional variables","Additional variables" +"Other variables","Other variables" diff --git a/man/align_axes.Rd b/man/align_axes.Rd index 6d3e79e2..f403e1a7 100644 --- a/man/align_axes.Rd +++ b/man/align_axes.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{align_axes} \alias{align_axes} \title{Aligns axes between plots} diff --git a/man/all_but.Rd b/man/all_but.Rd index e2453d15..8dc3f46e 100644 --- a/man/all_but.Rd +++ b/man/all_but.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{all_but} \alias{all_but} \title{Select all from vector but} diff --git a/man/available_plots.Rd b/man/available_plots.Rd new file mode 100644 index 00000000..0ee1d5ac --- /dev/null +++ b/man/available_plots.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot-helpers.R +\name{available_plots} +\alias{available_plots} +\title{Implemented functions} +\usage{ +available_plots() +} +\value{ +list +} +\description{ +Library of supported functions. The list name and "descr" element should be +unique for each element on list. +\itemize{ +\item fun: the plotting function +\item fun.args: default parameters for the plotting function +\item descr: Plot description +\item note: Short note/description of the function for displaying in ui and docs +\item primary.type: Primary variable data type (see \link{data_type}) +\item base: holds a list of parameters for plot input fields generation +Secondary and tertiary variable input fields are mandatory. +} +} +\examples{ +available_plots() |> str() +} diff --git a/man/clean_common_axis.Rd b/man/clean_common_axis.Rd index 175053c9..67197d46 100644 --- a/man/clean_common_axis.Rd +++ b/man/clean_common_axis.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{clean_common_axis} \alias{clean_common_axis} \title{Extract and clean axis ranges} diff --git a/man/data-plots.Rd b/man/data-plots.Rd index 4222466f..e6d84e08 100644 --- a/man/data-plots.Rd +++ b/man/data-plots.Rd @@ -1,7 +1,7 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R, R/plot_bar.R, R/plot_box.R, -% R/plot_hbar.R, R/plot_likert.R, R/plot_ridge.R, R/plot_sankey.R, -% R/plot_scatter.R, R/plot_violin.R +% Please edit documentation in R/data_plots.R, R/plot-helpers.R, R/plot_bar.R, +% R/plot_box.R, R/plot_hbar.R, R/plot_likert.R, R/plot_ridge.R, +% R/plot_sankey.R, R/plot_scatter.R, R/plot_violin.R \name{data-plots} \alias{data-plots} \alias{data_visuals_ui} @@ -22,7 +22,7 @@ \usage{ data_visuals_ui(id, tab_title = "Plots", ...) -data_visuals_server(id, data, palettes, ...) +data_visuals_server(id, data, palettes = color_choices(), ...) create_plot(data, type, pri, sec, ter = NULL, color.palette = "viridis", ...) @@ -50,9 +50,9 @@ plot_box(data, pri, sec, ter = NULL, color.palette = "viridis", ...) plot_box_single(data, pri, sec = NULL, seed = 2103, color.palette = "viridis") -plot_hbars(data, pri, sec, ter = NULL, color.palette = "viridis") +plot_hbars(data, pri, sec, ter = NULL, color.palette = "viridis", ...) -plot_likert(data, pri, sec = NULL, ter = NULL, color.palette = "viridis") +plot_likert(data, pri, sec = NULL, ter = NULL, color.palette = "viridis", ...) plot_ridge(data, x, y, z = NULL, color.palette = "viridis", ...) @@ -69,12 +69,13 @@ plot_sankey( default.color = "#2986cc", box.color = "#1E4B66", na.color = "grey80", - missing.level = "Missing" + missing.level = "Missing", + ... ) -plot_scatter(data, pri, sec, ter = NULL, color.palette = "viridis") +plot_scatter(data, pri, sec, ter = NULL, color.palette = "viridis", ...) -plot_violin(data, pri, sec, ter = NULL, color.palette = "viridis") +plot_violin(data, pri, sec, ter = NULL, color.palette = "viridis", ...) } \arguments{ \item{id}{Module id. (Use 'ns("id")')} diff --git a/man/get_input_params.Rd b/man/get_input_params.Rd new file mode 100644 index 00000000..6766d73e --- /dev/null +++ b/man/get_input_params.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot-helpers.R +\name{get_input_params} +\alias{get_input_params} +\title{Get the function parameters based on the selected function description} +\usage{ +get_input_params(data) +} +\arguments{ +\item{data}{vector} +} +\value{ +list +} +\description{ +Get the function parameters based on the selected function description +} +\examples{ +ls <- mtcars |> + default_parsing() |> + dplyr::pull(mpg) |> + possible_plots() |> + (\(.x){ + .x[[1]] + })() |> + get_input_params() +} diff --git a/man/get_label.Rd b/man/get_label.Rd index 108fd372..c808209e 100644 --- a/man/get_label.Rd +++ b/man/get_label.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{get_label} \alias{get_label} \title{Print label, and if missing print variable name for plots} diff --git a/man/get_plot_options.Rd b/man/get_plot_options.Rd index 08c04496..83001d38 100644 --- a/man/get_plot_options.Rd +++ b/man/get_plot_options.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{get_plot_options} \alias{get_plot_options} \title{Get the function options based on the selected function description} diff --git a/man/line_break.Rd b/man/line_break.Rd index 65c987c7..d926556e 100644 --- a/man/line_break.Rd +++ b/man/line_break.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{line_break} \alias{line_break} \title{Line breaking at given number of characters for nicely plotting labels} diff --git a/man/plot_euler_single.Rd b/man/plot_euler_single.Rd index f481d5af..22d425c2 100644 --- a/man/plot_euler_single.Rd +++ b/man/plot_euler_single.Rd @@ -4,7 +4,7 @@ \alias{plot_euler_single} \title{Easily plot single euler diagrams} \usage{ -plot_euler_single(data, color.palette = "viridis") +plot_euler_single(data, color.palette = "viridis", ...) } \value{ ggplot2 object diff --git a/man/possible_plots.Rd b/man/possible_plots.Rd index 28c0b623..d1519e38 100644 --- a/man/possible_plots.Rd +++ b/man/possible_plots.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{possible_plots} \alias{possible_plots} \title{Get possible regression models} \usage{ -possible_plots(data) +possible_plots(data, source_list = supported_plots()) } \arguments{ \item{data}{data} diff --git a/man/selectPlotVariables.Rd b/man/selectPlotVariables.Rd new file mode 100644 index 00000000..f9e63e5d --- /dev/null +++ b/man/selectPlotVariables.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot-helpers.R +\name{selectPlotVariables} +\alias{selectPlotVariables} +\title{Wrapper for columnSelectInput} +\usage{ +selectPlotVariables(data, exclude = NULL, allow_none = TRUE, var_types, ...) +} +\description{ +Wrapper for columnSelectInput +} diff --git a/man/subset_types.Rd b/man/subset_types.Rd index 61fced5e..a33e1561 100644 --- a/man/subset_types.Rd +++ b/man/subset_types.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{subset_types} \alias{subset_types} \title{Easily subset by data type function} diff --git a/man/supported_plots.Rd b/man/supported_plots.Rd index c91ad753..caa250e3 100644 --- a/man/supported_plots.Rd +++ b/man/supported_plots.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{supported_plots} \alias{supported_plots} \title{Implemented functions} diff --git a/man/wrap_plot_list.Rd b/man/wrap_plot_list.Rd index 40cf0ba1..dcf1ae64 100644 --- a/man/wrap_plot_list.Rd +++ b/man/wrap_plot_list.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R +% Please edit documentation in R/plot-helpers.R \name{wrap_plot_list} \alias{wrap_plot_list} \title{Wrapping}