From bc8aa7b583e1d88486edbf46617a74410c2b7371 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Wed, 5 Mar 2025 21:13:06 +0100 Subject: [PATCH] too much.. --- DESCRIPTION | 3 +- NAMESPACE | 41 ++- R/app_version.R | 2 +- R/data_plots.R | 267 ++++++++++++++-- R/shiny_freesearcheR.R | 2 +- R/update-factor-ext.R | 1 - inst/apps/freesearcheR/app.R | 285 +++++++++++++++--- .../shinyapps.io/agdamsbo/freesearcheR.dcf | 2 +- man/all_but.Rd | 22 ++ man/append_list.Rd | 27 ++ man/columnSelectInput.Rd | 45 +++ man/contrast_text.Rd | 52 ++++ man/data-correlations.Rd | 16 +- man/data-plots.Rd | 70 +++++ man/get_label.Rd | 24 ++ man/get_plot_options.Rd | 27 ++ man/is_valid_redcap_url.Rd | 22 ++ man/is_valid_token.Rd | 20 ++ man/{launch.Rd => launch_freesearcheR.Rd} | 6 +- man/line_break.Rd | 14 + man/plot_sankey_single.Rd | 22 ++ man/possible_plots.Rd | 28 ++ man/redcap_read_shiny_module.Rd | 20 +- man/sankey_ready.Rd | 19 ++ man/subset_types.Rd | 26 ++ man/supported_plots.Rd | 25 ++ man/update-factor.Rd | 48 +++ man/vertical_stacked_bars.Rd | 23 ++ 28 files changed, 1064 insertions(+), 95 deletions(-) create mode 100644 man/all_but.Rd create mode 100644 man/append_list.Rd create mode 100644 man/columnSelectInput.Rd create mode 100644 man/contrast_text.Rd create mode 100644 man/data-plots.Rd create mode 100644 man/get_label.Rd create mode 100644 man/get_plot_options.Rd create mode 100644 man/is_valid_redcap_url.Rd create mode 100644 man/is_valid_token.Rd rename man/{launch.Rd => launch_freesearcheR.Rd} (78%) create mode 100644 man/line_break.Rd create mode 100644 man/plot_sankey_single.Rd create mode 100644 man/possible_plots.Rd create mode 100644 man/sankey_ready.Rd create mode 100644 man/subset_types.Rd create mode 100644 man/supported_plots.Rd create mode 100644 man/update-factor.Rd create mode 100644 man/vertical_stacked_bars.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 9cfd9f5..469406f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -64,7 +64,8 @@ Imports: Hmisc, ggstats, rempsyc, - ggridges + ggridges, + ggalluvial Suggests: styler, devtools, diff --git a/NAMESPACE b/NAMESPACE index ee1dcc4..67e6b4a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -4,11 +4,14 @@ S3method(cut,hms) S3method(plot,tbl_regression) export(add_class_icon) export(add_sparkline) +export(all_but) export(argsstring2list) export(baseline_table) export(clean_date) export(clean_sep) +export(contrast_text) export(create_overview_datagrid) +export(create_plot) export(custom_theme) export(cut_variable_server) export(cut_variable_ui) @@ -16,12 +19,16 @@ export(data_correlations_server) export(data_correlations_ui) export(data_summary_server) export(data_summary_ui) +export(data_visuals_server) +export(data_visuals_ui) export(default_format_arguments) export(default_parsing) export(factorize) export(file_export) export(format_writer) export(get_fun_options) +export(get_label) +export(get_plot_options) export(getfun) export(gg_theme_export) export(gg_theme_shiny) @@ -29,16 +36,27 @@ export(index_embed) export(is_any_class) export(is_consecutive) export(is_datetime) -export(launch) +export(is_valid_redcap_url) +export(is_valid_token) +export(launch_freesearcheR) +export(line_break) export(m_datafileUI) export(m_redcap_readServer) export(m_redcap_readUI) export(merge_long) export(modal_cut_variable) +export(modal_update_factor) export(modify_qmd) export(outcome_type) export(overview_vars) +export(plot_hbars) +export(plot_ridge) +export(plot_sankey) +export(plot_sankey_single) +export(plot_scatter) +export(plot_violin) export(possible_functions) +export(possible_plots) export(read_input) export(regression_model) export(regression_model_list) @@ -47,17 +65,25 @@ export(regression_model_uv_list) export(regression_table) export(remove_empty_cols) export(remove_na_attr) +export(sankey_ready) export(shiny_freesearcheR) export(specify_qmd_format) +export(subset_types) export(supported_functions) +export(supported_plots) export(tbl_merge) +export(update_factor_server) +export(update_factor_ui) export(update_variables_server) export(update_variables_ui) +export(vertical_stacked_bars) export(winbox_cut_variable) +export(winbox_update_factor) export(write_quarto) importFrom(classInt,classIntervals) importFrom(data.table,as.data.table) importFrom(data.table,data.table) +importFrom(grDevices,col2rgb) importFrom(graphics,abline) importFrom(graphics,axis) importFrom(graphics,hist) @@ -65,6 +91,7 @@ importFrom(graphics,par) importFrom(graphics,plot.new) importFrom(graphics,plot.window) importFrom(htmltools,tagList) +importFrom(htmltools,tags) importFrom(rlang,"%||%") importFrom(rlang,call2) importFrom(rlang,expr) @@ -72,30 +99,42 @@ importFrom(rlang,set_names) importFrom(rlang,sym) importFrom(rlang,syms) importFrom(shiny,NS) +importFrom(shiny,actionButton) importFrom(shiny,bindEvent) importFrom(shiny,checkboxInput) importFrom(shiny,column) importFrom(shiny,fluidRow) +importFrom(shiny,getDefaultReactiveDomain) +importFrom(shiny,icon) +importFrom(shiny,isTruthy) importFrom(shiny,modalDialog) importFrom(shiny,moduleServer) importFrom(shiny,numericInput) importFrom(shiny,observeEvent) importFrom(shiny,plotOutput) importFrom(shiny,reactive) +importFrom(shiny,reactiveValues) importFrom(shiny,renderPlot) importFrom(shiny,req) +importFrom(shiny,selectizeInput) importFrom(shiny,showModal) +importFrom(shiny,tagList) importFrom(shiny,textInput) importFrom(shiny,uiOutput) +importFrom(shiny,updateActionButton) importFrom(shinyWidgets,WinBox) importFrom(shinyWidgets,noUiSliderInput) +importFrom(shinyWidgets,prettyCheckbox) importFrom(shinyWidgets,updateVirtualSelect) importFrom(shinyWidgets,virtualSelectInput) importFrom(shinyWidgets,wbControls) importFrom(shinyWidgets,wbOptions) importFrom(stats,as.formula) importFrom(toastui,datagrid) +importFrom(toastui,datagridOutput) importFrom(toastui,datagridOutput2) importFrom(toastui,grid_colorbar) +importFrom(toastui,grid_columns) +importFrom(toastui,renderDatagrid) importFrom(toastui,renderDatagrid2) importFrom(utils,type.convert) diff --git a/R/app_version.R b/R/app_version.R index 2fa4409..81d6d18 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'250227_1342' +app_version <- function()'250305_1101' diff --git a/R/data_plots.R b/R/data_plots.R index 484e83a..d4d0109 100644 --- a/R/data_plots.R +++ b/R/data_plots.R @@ -8,7 +8,7 @@ #' @returns Shiny ui module #' @export #' -data_visuals_ui <- function(id, tab_title="Plots", ...) { +data_visuals_ui <- function(id, tab_title = "Plots", ...) { ns <- shiny::NS(id) # bslib::navset_bar( @@ -29,7 +29,7 @@ data_visuals_ui <- function(id, tab_title="Plots", ...) { bslib::accordion_panel( title = "Advanced", icon = bsicons::bs_icon("gear") - ), + ), bslib::accordion_panel( title = "Download", icon = bsicons::bs_icon("download"), @@ -40,7 +40,7 @@ data_visuals_ui <- function(id, tab_title="Plots", ...) { max = 300, value = 100, step = 1, - format = shinyWidgets::wNumbFormat(decimals=0), + format = shinyWidgets::wNumbFormat(decimals = 0), color = datamods:::get_primary_color() ), shinyWidgets::noUiSliderInput( @@ -50,7 +50,7 @@ data_visuals_ui <- function(id, tab_title="Plots", ...) { max = 300, value = 100, step = 1, - format = shinyWidgets::wNumbFormat(decimals=0), + format = shinyWidgets::wNumbFormat(decimals = 0), color = datamods:::get_primary_color() ), shiny::selectInput( @@ -163,7 +163,6 @@ data_visuals_server <- function(id, ), none_label = "No variable" ) - }) output$tertiary <- shiny::renderUI({ @@ -213,12 +212,14 @@ data_visuals_server <- function(id, }), content = function(file) { shiny::withProgress(message = "Drawing the plot. Hold on for a moment..", { - ggplot2::ggsave(filename = file, - plot = rv$plot(), - width = input$width, - height = input$height, - dpi = 300, - units = "mm",scale = 2) + ggplot2::ggsave( + filename = file, + plot = rv$plot(), + width = input$width, + height = input$height, + dpi = 300, + units = "mm", scale = 2 + ) }) } ) @@ -238,7 +239,7 @@ data_visuals_server <- function(id, #' @param data vector #' @param ... exclude #' -#' @returns +#' @returns vector #' @export #' #' @examples @@ -253,7 +254,7 @@ all_but <- function(data, ...) { #' @param types desired types #' @param type.fun function to get type. Default is outcome_type #' -#' @returns +#' @returns vector #' @export #' #' @examples @@ -290,7 +291,8 @@ subset_types <- function(data, types, type.fun = outcome_type) { supported_plots <- function() { list( plot_hbars = list( - descr = "Stacked horizontal bars (Grotta bars)", + descr = "Stacked horizontal bars", + note = "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", "ordinal"), secondary.type = c("dichotomous", "ordinal"), tertiary.type = c("dichotomous", "ordinal"), @@ -298,6 +300,7 @@ supported_plots <- function() { ), plot_violin = list( descr = "Violin plot", + note = "A modern alternative to the classic boxplot to visualise data distribution", primary.type = c("continuous", "dichotomous", "ordinal"), secondary.type = c("dichotomous", "ordinal"), tertiary.type = c("dichotomous", "ordinal"), @@ -305,13 +308,23 @@ supported_plots <- function() { ), plot_ridge = list( descr = "Ridge plot", + note = "An alternative option to visualise data distribution", primary.type = "continuous", secondary.type = c("dichotomous", "ordinal"), tertiary.type = c("dichotomous", "ordinal"), secondary.extra = NULL ), + plot_sankey = list( + descr = "Sankey plot", + note = "A way of visualising change between groups", + primary.type = c("dichotomous", "ordinal"), + secondary.type = c("dichotomous", "ordinal"), + tertiary.type = c("dichotomous", "ordinal"), + secondary.extra = NULL + ), plot_scatter = list( descr = "Scatter plot", + note = "A classic way of showing the association between to variables", primary.type = "continuous", secondary.type = c("continuous", "ordinal"), tertiary.type = c("dichotomous", "ordinal"), @@ -322,9 +335,11 @@ supported_plots <- function() { #' Title #' -#' @returns +#' @returns ggplot2 object #' @export #' +#' @name data-plots +#' #' @examples #' mtcars |> #' default_parsing() |> @@ -422,7 +437,9 @@ get_plot_options <- function(data) { #' @param type plot type (derived from possible_plots() and matches custom function) #' @param ... ignored for now #' -#' @returns +#' @name data-plots +#' +#' @returns ggplot2 object #' @export #' #' @examples @@ -448,6 +465,8 @@ create_plot <- function(data, type, x, y, z = NULL, ...) { #' @returns ggplot2 object #' @export #' +#' @name data-plots +#' #' @examples #' mtcars |> plot_hbars(x = "carb", y = "cyl") #' mtcars |> plot_hbars(x = "carb", y = NULL) @@ -547,6 +566,7 @@ vertical_stacked_bars <- function(data, #' #' @examples #' mtcars |> get_label(var = "mpg") +#' mtcars |> get_label() #' mtcars$mpg |> get_label() #' gtsummary::trial |> get_label(var = "trt") #' 1:10 |> get_label() @@ -554,13 +574,16 @@ get_label <- function(data, var = NULL) { if (!is.null(var)) { data <- data[[var]] } - out <- REDCapCAST::get_attr(data = data, attr = "label") if (is.na(out)) { if (is.null(var)) { out <- deparse(substitute(data)) } else { - out <- gsub('\"', "", deparse(substitute(var))) + if (is.symbol(var)) { + out <- gsub('\"', "", deparse(substitute(var))) + } else { + out <- var + } } } out @@ -572,6 +595,8 @@ get_label <- function(data, var = NULL) { #' @returns ggplot2 object #' @export #' +#' @name data-plots +#' #' @examples #' mtcars |> plot_violin(x = "mpg", y = "cyl", z = "gear") plot_violin <- function(data, x, y, z = NULL) { @@ -593,11 +618,13 @@ plot_violin <- function(data, x, y, z = NULL) { } -#' Beatiful violin plot +#' Beautiful violin plot #' #' @returns ggplot2 object #' @export #' +#' @name data-plots +#' #' @examples #' mtcars |> plot_scatter(x = "mpg", y = "wt") plot_scatter <- function(data, x, y, z = NULL) { @@ -617,3 +644,205 @@ plot_scatter <- function(data, x, y, z = NULL) { } } +#' Readying data for sankey plot +#' +#' @param data +#' @param x +#' @param y +#' @param z +#' +#' @returns +#' @export +#' +#' @examples +#' ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), last = sample(c(letters[1:4], NA), 100, TRUE, prob = c(rep(.23, 4), .08))) +#' ds |> sankey_ready("first", "last") +#' ds |> sankey_ready("first", "last", numbers = "percentage") +sankey_ready <- function(data, x, y, z = NULL, numbers = "count") { + ## TODO: Ensure ordering x and y + + if (is.null(z)) { + out <- dplyr::count(data, !!dplyr::sym(x), !!dplyr::sym(y)) + } else { + out <- dplyr::count(data, !!dplyr::sym(x), !!dplyr::sym(y), !!dplyr::sym(z)) + } + out <- out |> + dplyr::group_by(!!dplyr::sym(x)) |> + dplyr::mutate(gx.sum = sum(n)) |> + dplyr::ungroup() |> + dplyr::group_by(!!dplyr::sym(y)) |> + dplyr::mutate(gy.sum = sum(n)) |> + dplyr::ungroup() + + if (numbers == "count") { + out <- out |> dplyr::mutate( + lx = factor(paste0(!!dplyr::sym(x), "\n(n=", gx.sum, ")")), + ly = factor(paste0(!!dplyr::sym(y), "\n(n=", gy.sum, ")")) + ) + } else if (numbers == "percentage") { + out <- out |> dplyr::mutate( + lx = factor(paste0(!!dplyr::sym(x), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)")), + ly = factor(paste0(!!dplyr::sym(y), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)")) + ) + } + + if (is.factor(data[[x]])){ + index <- match(levels(data[[x]]),str_remove_last(levels(out$lx),"\n")) + out$lx <- factor(out$lx,levels=levels(out$lx)[index]) + } + + if (is.factor(data[[y]])){ + index <- match(levels(data[[y]]),str_remove_last(levels(out$ly),"\n")) + out$ly <- factor(out$ly,levels=levels(out$ly)[index]) + } + + out +} + +str_remove_last <- function(data,pattern="\n"){ + strsplit(data,split = pattern) |> + lapply(\(.x)paste(unlist(.x[[-length(.x)]]),collapse=pattern)) |> + unlist() +} + +#' Line breaking at given number of characters for nicely plotting labels +#' +#' @param data +#' @param lineLength +#' +#' @returns +#' @export +#' +#' @examples +line_break <- function(data, lineLength = 20) { + # gsub(paste0('(.{1,',lineLength,'})(\\s)'), '\\1\n', data) + paste(strwrap(data, lineLength), collapse = "\n") + ## https://stackoverflow.com/a/29847221 +} + +#' Beautiful sankey plot with option to split by a tertiary group +#' +#' @returns ggplot2 object +#' @export +#' +#' @name data-plots +#' +#' @examples +#' ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), last = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE))) +#' ds |> plot_sankey("first", "last") +#' ds |> plot_sankey("first", "last", color.group = "y") +#' ds |> plot_sankey("first", "last", z = "g", color.group = "y") +plot_sankey <- function(data, x, y, z = NULL, color.group = "x", colors = NULL) { + if (!is.null(z)) { + ds <- split(data, data[z]) + } else { + ds <- list(data) + } + + out <- lapply(ds, \(.ds){ + plot_sankey_single(.ds,x = x, y = y,color.group = color.group, colors = colors) + }) + + patchwork::wrap_plots(out) +} + +default_theme <- function() { + theme_void() +} + +#' Beautiful sankey plot +#' +#' @param color.group +#' @param colors +#' +#' @returns ggplot2 object +#' @export +#' +#' @examples +#' ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), last = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE))) +#' ds |> plot_sankey_single("first", "last") +#' ds |> plot_sankey_single("first", "last", color.group = "y") +plot_sankey_single <- function(data,x,y, color.group = "x", colors = NULL){ + data <- data |> sankey_ready(x = x, y = y) +# browser() + library(ggalluvial) + + na.color <- "#2986cc" + box.color <- "#1E4B66" + + if (is.null(colors)) { + if (color.group == "y") { + main.colors <- viridisLite::viridis(n = length(levels(data[[y]]))) + secondary.colors <- rep(na.color, length(levels(data[[x]]))) + label.colors <- Reduce(c, lapply(list(secondary.colors, rev(main.colors)), contrast_text)) + } else { + main.colors <- viridisLite::viridis(n = length(levels(data[[x]]))) + secondary.colors <- rep(na.color, length(levels(data[[y]]))) + label.colors <- Reduce(c, lapply(list(rev(main.colors), secondary.colors), contrast_text)) + } + colors <- c(na.color, main.colors, secondary.colors) + } else { + label.colors <- contrast_text(colors) + } + + group_labels <- c(get_label(data, x), get_label(data, y)) |> + sapply(line_break) |> + unname() + + p <- ggplot2::ggplot(data, ggplot2::aes(y = n, axis1 = lx, axis2 = ly)) + + if (color.group == "y") { + p <- p + + ggalluvial::geom_alluvium( + ggplot2::aes(fill = !!dplyr::sym(y), color = !!dplyr::sym(y)), + width = 1 / 16, + alpha = .8, + knot.pos = 0.4, + curve_type = "sigmoid" + ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(y)), + size = 2, + width = 1 / 3.4 + ) + } else { + p <- p + + ggalluvial::geom_alluvium( + ggplot2::aes(fill = !!dplyr::sym(x), color = !!dplyr::sym(x)), + width = 1 / 16, + alpha = .8, + knot.pos = 0.4, + curve_type = "sigmoid" + ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(x)), + size = 2, + width = 1 / 3.4 + ) + } + + p + + ggplot2::geom_text( + stat = "stratum", + ggplot2::aes(label = after_stat(stratum)), + colour = label.colors, + size = 8, + lineheight = 1 + ) + + ggplot2::scale_x_continuous( + breaks = 1:2, + labels = group_labels + ) + + ggplot2::scale_fill_manual(values = colors[-1], na.value = colors[1]) + + ggplot2::scale_color_manual(values = main.colors) + + ggplot2::theme_void() + + ggplot2::theme( + legend.position = "none", + # panel.grid.major = element_blank(), + # panel.grid.minor = element_blank(), + # axis.text.y = element_blank(), + # axis.title.y = element_blank(), + axis.text.x = ggplot2::element_text(size = 20), + # text = element_text(size = 5), + # plot.title = element_blank(), + # panel.background = ggplot2::element_rect(fill = "white"), + plot.background = ggplot2::element_rect(fill = "white"), + panel.border = ggplot2::element_blank() + ) +} diff --git a/R/shiny_freesearcheR.R b/R/shiny_freesearcheR.R index ce3020c..337376b 100644 --- a/R/shiny_freesearcheR.R +++ b/R/shiny_freesearcheR.R @@ -32,6 +32,6 @@ shiny_freesearcheR <- function(...) { #' @returns shiny app #' @export #' -launch <- function(...){ +launch_freesearcheR <- function(...){ shiny_freesearcheR(...) } diff --git a/R/update-factor-ext.R b/R/update-factor-ext.R index d67bf86..07dc284 100644 --- a/R/update-factor-ext.R +++ b/R/update-factor-ext.R @@ -22,7 +22,6 @@ #' #' @name update-factor #' -#' @example examples/update_factor.R update_factor_ui <- function(id) { ns <- NS(id) tagList( diff --git a/inst/apps/freesearcheR/app.R b/inst/apps/freesearcheR/app.R index d8f7600..7316be2 100644 --- a/inst/apps/freesearcheR/app.R +++ b/inst/apps/freesearcheR/app.R @@ -10,7 +10,7 @@ #### Current file: R//app_version.R ######## -app_version <- function()'250227_1342' +app_version <- function()'250305_1101' ######## @@ -984,7 +984,7 @@ plot_histogram <- function(data, column, bins = 30, breaks = NULL, color = "#112 #' @returns Shiny ui module #' @export #' -data_visuals_ui <- function(id, tab_title="Plots", ...) { +data_visuals_ui <- function(id, tab_title = "Plots", ...) { ns <- shiny::NS(id) # bslib::navset_bar( @@ -1005,7 +1005,7 @@ data_visuals_ui <- function(id, tab_title="Plots", ...) { bslib::accordion_panel( title = "Advanced", icon = bsicons::bs_icon("gear") - ), + ), bslib::accordion_panel( title = "Download", icon = bsicons::bs_icon("download"), @@ -1016,7 +1016,7 @@ data_visuals_ui <- function(id, tab_title="Plots", ...) { max = 300, value = 100, step = 1, - format = shinyWidgets::wNumbFormat(decimals=0), + format = shinyWidgets::wNumbFormat(decimals = 0), color = datamods:::get_primary_color() ), shinyWidgets::noUiSliderInput( @@ -1026,7 +1026,7 @@ data_visuals_ui <- function(id, tab_title="Plots", ...) { max = 300, value = 100, step = 1, - format = shinyWidgets::wNumbFormat(decimals=0), + format = shinyWidgets::wNumbFormat(decimals = 0), color = datamods:::get_primary_color() ), shiny::selectInput( @@ -1139,7 +1139,6 @@ data_visuals_server <- function(id, ), none_label = "No variable" ) - }) output$tertiary <- shiny::renderUI({ @@ -1189,12 +1188,14 @@ data_visuals_server <- function(id, }), content = function(file) { shiny::withProgress(message = "Drawing the plot. Hold on for a moment..", { - ggplot2::ggsave(filename = file, - plot = rv$plot(), - width = input$width, - height = input$height, - dpi = 300, - units = "mm",scale = 2) + ggplot2::ggsave( + filename = file, + plot = rv$plot(), + width = input$width, + height = input$height, + dpi = 300, + units = "mm", scale = 2 + ) }) } ) @@ -1214,7 +1215,7 @@ data_visuals_server <- function(id, #' @param data vector #' @param ... exclude #' -#' @returns +#' @returns vector #' @export #' #' @examples @@ -1229,7 +1230,7 @@ all_but <- function(data, ...) { #' @param types desired types #' @param type.fun function to get type. Default is outcome_type #' -#' @returns +#' @returns vector #' @export #' #' @examples @@ -1266,7 +1267,8 @@ subset_types <- function(data, types, type.fun = outcome_type) { supported_plots <- function() { list( plot_hbars = list( - descr = "Stacked horizontal bars (Grotta bars)", + descr = "Stacked horizontal bars", + note = "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", "ordinal"), secondary.type = c("dichotomous", "ordinal"), tertiary.type = c("dichotomous", "ordinal"), @@ -1274,6 +1276,7 @@ supported_plots <- function() { ), plot_violin = list( descr = "Violin plot", + note = "A modern alternative to the classic boxplot to visualise data distribution", primary.type = c("continuous", "dichotomous", "ordinal"), secondary.type = c("dichotomous", "ordinal"), tertiary.type = c("dichotomous", "ordinal"), @@ -1281,13 +1284,23 @@ supported_plots <- function() { ), plot_ridge = list( descr = "Ridge plot", + note = "An alternative option to visualise data distribution", primary.type = "continuous", secondary.type = c("dichotomous", "ordinal"), tertiary.type = c("dichotomous", "ordinal"), secondary.extra = NULL ), + plot_sankey = list( + descr = "Sankey plot", + note = "A way of visualising change between groups", + primary.type = c("dichotomous", "ordinal"), + secondary.type = c("dichotomous", "ordinal"), + tertiary.type = c("dichotomous", "ordinal"), + secondary.extra = NULL + ), plot_scatter = list( descr = "Scatter plot", + note = "A classic way of showing the association between to variables", primary.type = "continuous", secondary.type = c("continuous", "ordinal"), tertiary.type = c("dichotomous", "ordinal"), @@ -1298,9 +1311,11 @@ supported_plots <- function() { #' Title #' -#' @returns +#' @returns ggplot2 object #' @export #' +#' @name data-plots +#' #' @examples #' mtcars |> #' default_parsing() |> @@ -1398,7 +1413,9 @@ get_plot_options <- function(data) { #' @param type plot type (derived from possible_plots() and matches custom function) #' @param ... ignored for now #' -#' @returns +#' @name data-plots +#' +#' @returns ggplot2 object #' @export #' #' @examples @@ -1424,6 +1441,8 @@ create_plot <- function(data, type, x, y, z = NULL, ...) { #' @returns ggplot2 object #' @export #' +#' @name data-plots +#' #' @examples #' mtcars |> plot_hbars(x = "carb", y = "cyl") #' mtcars |> plot_hbars(x = "carb", y = NULL) @@ -1523,6 +1542,7 @@ vertical_stacked_bars <- function(data, #' #' @examples #' mtcars |> get_label(var = "mpg") +#' mtcars |> get_label() #' mtcars$mpg |> get_label() #' gtsummary::trial |> get_label(var = "trt") #' 1:10 |> get_label() @@ -1530,13 +1550,16 @@ get_label <- function(data, var = NULL) { if (!is.null(var)) { data <- data[[var]] } - out <- REDCapCAST::get_attr(data = data, attr = "label") if (is.na(out)) { if (is.null(var)) { out <- deparse(substitute(data)) } else { - out <- gsub('\"', "", deparse(substitute(var))) + if (is.symbol(var)) { + out <- gsub('\"', "", deparse(substitute(var))) + } else { + out <- var + } } } out @@ -1548,6 +1571,8 @@ get_label <- function(data, var = NULL) { #' @returns ggplot2 object #' @export #' +#' @name data-plots +#' #' @examples #' mtcars |> plot_violin(x = "mpg", y = "cyl", z = "gear") plot_violin <- function(data, x, y, z = NULL) { @@ -1569,11 +1594,13 @@ plot_violin <- function(data, x, y, z = NULL) { } -#' Beatiful violin plot +#' Beautiful violin plot #' #' @returns ggplot2 object #' @export #' +#' @name data-plots +#' #' @examples #' mtcars |> plot_scatter(x = "mpg", y = "wt") plot_scatter <- function(data, x, y, z = NULL) { @@ -1593,6 +1620,194 @@ plot_scatter <- function(data, x, y, z = NULL) { } } +#' Readying data for sankey plot +#' +#' @param data +#' @param x +#' @param y +#' @param z +#' +#' @returns +#' @export +#' +#' @examples +#' ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), last = sample(c(letters[1:4], NA), 100, TRUE, prob = c(rep(.23, 4), .08))) +#' ds |> sankey_ready("first", "last") +#' ds |> sankey_ready("first", "last", numbers = "percentage") +sankey_ready <- function(data, x, y, z = NULL, numbers = "count") { + ## TODO: Ensure ordering x and y + + if (is.null(z)) { + out <- dplyr::count(data, !!dplyr::sym(x), !!dplyr::sym(y)) + } else { + out <- dplyr::count(data, !!dplyr::sym(x), !!dplyr::sym(y), !!dplyr::sym(z)) + } + out <- out |> + dplyr::group_by(!!dplyr::sym(x)) |> + dplyr::mutate(gx.sum = sum(n)) |> + dplyr::ungroup() |> + dplyr::group_by(!!dplyr::sym(y)) |> + dplyr::mutate(gy.sum = sum(n)) |> + dplyr::ungroup() + + + if (numbers == "count") { + out <- out |> dplyr::mutate( + lx = factor(paste0(!!dplyr::sym(x), "\n(n=", gx.sum, ")")), + ly = factor(paste0(!!dplyr::sym(y), "\n(n=", gy.sum, ")")) + ) + } else if (numbers == "percentage") { + out <- out |> dplyr::mutate( + lx = factor(paste0(!!dplyr::sym(x), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)")), + ly = factor(paste0(!!dplyr::sym(y), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)")) + ) + } + out +} + +#' Line breaking at given number of characters for nicely plotting labels +#' +#' @param data +#' @param lineLength +#' +#' @returns +#' @export +#' +#' @examples +line_break <- function(data, lineLength = 20) { + # gsub(paste0('(.{1,',lineLength,'})(\\s)'), '\\1\n', data) + paste(strwrap(data, lineLength), collapse = "\n") + ## https://stackoverflow.com/a/29847221 +} + +#' Beautiful sankey plot with option to split by a tertiary group +#' +#' @returns ggplot2 object +#' @export +#' +#' @name data-plots +#' +#' @examples +#' ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), last = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE))) +#' ds |> plot_sankey("first", "last") +#' ds |> plot_sankey("first", "last", color.group = "y") +#' ds |> plot_sankey("first", "last", z = "g", color.group = "y") +plot_sankey <- function(data, x, y, z = NULL, color.group = "x", colors = NULL) { + if (!is.null(z)) { + ds <- split(data, data[z]) + } else { + ds <- list(data) + } + + out <- lapply(ds, \(.ds){ + plot_sankey_single(.ds,x = x, y = y,color.group = color.group, colors = colors) + }) + + patchwork::wrap_plots(out) +} + +default_theme <- function() { + theme_void() +} + +#' Beautiful sankey plot +#' +#' @param color.group +#' @param colors +#' +#' @returns ggplot2 object +#' @export +#' +#' @examples +#' ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), last = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE))) +#' ds |> plot_sankey_single("first", "last") +#' ds |> plot_sankey_single("first", "last", color.group = "y") +plot_sankey_single <- function(data,x,y, color.group = "x", colors = NULL){ + data <- data |> sankey_ready(x = x, y = y) + + library(ggalluvial) + + na.color <- "#2986cc" + box.color <- "#1E4B66" + + if (is.null(colors)) { + if (color.group == "y") { + main.colors <- viridisLite::viridis(n = length(levels(data[[y]]))) + secondary.colors <- rep(na.color, length(levels(data[[x]]))) + label.colors <- Reduce(c, lapply(list(secondary.colors, rev(main.colors)), contrast_text)) + } else { + main.colors <- viridisLite::viridis(n = length(levels(data[[x]]))) + secondary.colors <- rep(na.color, length(levels(data[[y]]))) + label.colors <- Reduce(c, lapply(list(rev(main.colors), secondary.colors), contrast_text)) + } + colors <- c(na.color, main.colors, secondary.colors) + } else { + label.colors <- contrast_text(colors) + } + + + + group_labels <- c(get_label(data, x), get_label(data, y)) |> + sapply(line_break) |> + unname() + + p <- ggplot2::ggplot(data, ggplot2::aes(y = n, axis1 = lx, axis2 = ly)) + + if (color.group == "y") { + p <- p + + ggalluvial::geom_alluvium( + ggplot2::aes(fill = !!dplyr::sym(y), color = !!dplyr::sym(y)), + width = 1 / 16, + alpha = .8, + knot.pos = 0.4, + curve_type = "sigmoid" + ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(y)), + size = 2, + width = 1 / 3.4 + ) + } else { + p <- p + + ggalluvial::geom_alluvium( + ggplot2::aes(fill = !!dplyr::sym(x), color = !!dplyr::sym(x)), + width = 1 / 16, + alpha = .8, + knot.pos = 0.4, + curve_type = "sigmoid" + ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(x)), + size = 2, + width = 1 / 3.4 + ) + } + + p + + ggplot2::geom_text( + stat = "stratum", + ggplot2::aes(label = after_stat(stratum)), + colour = label.colors, + size = 8, + lineheight = 1 + ) + + ggplot2::scale_x_continuous( + breaks = 1:2, + labels = group_labels + ) + + ggplot2::scale_fill_manual(values = colors[-1], na.value = colors[1]) + + ggplot2::scale_color_manual(values = main.colors) + + ggplot2::theme_void() + + ggplot2::theme( + legend.position = "none", + # panel.grid.major = element_blank(), + # panel.grid.minor = element_blank(), + # axis.text.y = element_blank(), + # axis.title.y = element_blank(), + axis.text.x = ggplot2::element_text(size = 20), + # text = element_text(size = 5), + # plot.title = element_blank(), + # panel.background = ggplot2::element_rect(fill = "white"), + plot.background = ggplot2::element_rect(fill = "white"), + panel.border = ggplot2::element_blank() + ) +} ######## @@ -3811,7 +4026,7 @@ shiny_freesearcheR <- function(...) { #' @returns shiny app #' @export #' -launch <- function(...){ +launch_freesearcheR <- function(...){ shiny_freesearcheR(...) } @@ -3926,7 +4141,6 @@ gg_theme_export <- function(){ #' #' @name update-factor #' -#' @example examples/update_factor.R update_factor_ui <- function(id) { ns <- NS(id) tagList( @@ -6430,33 +6644,6 @@ server <- function(input, output, session) { gt::tab_header(gt::md(glue::glue("**Table 2: {rv$list$regression$params$descr}**"))) }) - # shiny::observe( - # # list( - # # input$plot_model - # # ), - # { - # shiny::req(rv$list$regression$tables) - # shiny::req(input$plot_model) - # tryCatch( - # { - # out <- merge_long(rv$list$regression, input$plot_model) |> - # plot.tbl_regression( - # colour = "variable", - # facet_col = "model" - # ) - # - # rv$list$regression$plot <- out - # }, - # warning = function(warn) { - # showNotification(paste0(warn), type = "warning") - # }, - # error = function(err) { - # showNotification(paste0("Plotting failed with the following error: ", err), type = "err") - # } - # ) - # } - # ) - output$regression_plot <- shiny::renderPlot( { # shiny::req(rv$list$regression$plot) diff --git a/inst/apps/freesearcheR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf b/inst/apps/freesearcheR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf index 5967f31..601efea 100644 --- a/inst/apps/freesearcheR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf +++ b/inst/apps/freesearcheR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf @@ -5,6 +5,6 @@ account: agdamsbo server: shinyapps.io hostUrl: https://api.shinyapps.io/v1 appId: 13611288 -bundleId: 9864963 +bundleId: 9881752 url: https://agdamsbo.shinyapps.io/freesearcheR/ version: 1 diff --git a/man/all_but.Rd b/man/all_but.Rd new file mode 100644 index 0000000..e2453d1 --- /dev/null +++ b/man/all_but.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data_plots.R +\name{all_but} +\alias{all_but} +\title{Select all from vector but} +\usage{ +all_but(data, ...) +} +\arguments{ +\item{data}{vector} + +\item{...}{exclude} +} +\value{ +vector +} +\description{ +Select all from vector but +} +\examples{ +all_but(1:10, c(2, 3), 11, 5) +} diff --git a/man/append_list.Rd b/man/append_list.Rd new file mode 100644 index 0000000..990f3a6 --- /dev/null +++ b/man/append_list.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/helpers.R +\name{append_list} +\alias{append_list} +\title{Append list with named index} +\usage{ +append_list(data, list, index) +} +\arguments{ +\item{data}{data to add to list} + +\item{list}{list} + +\item{index}{index name} +} +\value{ +list +} +\description{ +Append list with named index +} +\examples{ +ls_d <- list(test=c(1:20)) +ls_d <- list() +data.frame(letters[1:20],1:20) |> append_list(ls_d,"letters") +letters[1:20]|> append_list(ls_d,"letters") +} diff --git a/man/columnSelectInput.Rd b/man/columnSelectInput.Rd new file mode 100644 index 0000000..77f69e9 --- /dev/null +++ b/man/columnSelectInput.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/columnSelectInput.R +\name{columnSelectInput} +\alias{columnSelectInput} +\title{A selectizeInput customized for data frames with column labels} +\usage{ +columnSelectInput( + inputId, + label, + data, + selected = "", + ..., + col_subset = NULL, + placeholder = "", + onInitialize, + none_label = "No variable selected" +) +} +\arguments{ +\item{inputId}{passed to \code{\link[shiny]{selectizeInput}}} + +\item{label}{passed to \code{\link[shiny]{selectizeInput}}} + +\item{data}{\code{data.frame} object from which fields should be populated} + +\item{selected}{default selection} + +\item{...}{passed to \code{\link[shiny]{selectizeInput}}} + +\item{col_subset}{a \code{vector} containing the list of allowable columns to select} + +\item{placeholder}{passed to \code{\link[shiny]{selectizeInput}} options} + +\item{onInitialize}{passed to \code{\link[shiny]{selectizeInput}} options} + +\item{none_label}{label for "none" item} +} +\value{ +a \code{\link[shiny]{selectizeInput}} dropdown element +} +\description{ +Copied and modified from the IDEAFilter package +Adds the option to select "none" which is handled later +} +\keyword{internal} diff --git a/man/contrast_text.Rd b/man/contrast_text.Rd new file mode 100644 index 0000000..261e66f --- /dev/null +++ b/man/contrast_text.Rd @@ -0,0 +1,52 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/contrast_text.R +\name{contrast_text} +\alias{contrast_text} +\title{Contrast Text Color} +\usage{ +contrast_text( + background, + light_text = "white", + dark_text = "black", + threshold = 0.5, + method = "perceived_2", + ... +) +} +\arguments{ +\item{background}{A hex/named color value that represents the background.} + +\item{light_text}{A hex/named color value that represents the light text +color.} + +\item{dark_text}{A hex/named color value that represents the dark text color.} + +\item{threshold}{A numeric value between 0 and 1 that is used to determine +the luminance threshold of the background color for text color.} + +\item{method}{A character string that specifies the method for calculating +the luminance. Three different methods are available: +c("relative","perceived","perceived_2")} + +\item{...}{parameter overflow. Ignored.} +} +\value{ +A character string that contains the best contrast text color. +} +\description{ +Calculates the best contrast text color for a given +background color. +} +\details{ +This function aids in deciding the font color to print on a given background. +The function is based on the example provided by teppo: +https://stackoverflow.com/a/66669838/21019325. +The different methods provided are based on the methods outlined in the +StackOverflow thread: +https://stackoverflow.com/questions/596216/formula-to-determine-perceived-brightness-of-rgb-color +} +\examples{ +contrast_text(c("#F2F2F2", "blue")) + +contrast_text(c("#F2F2F2", "blue"), method="relative") +} diff --git a/man/data-correlations.Rd b/man/data-correlations.Rd index df65126..5ad3dbb 100644 --- a/man/data-correlations.Rd +++ b/man/data-correlations.Rd @@ -1,19 +1,25 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/correlations-module.R +% Please edit documentation in R/correlations-module.R, R/data_plots.R \name{data-correlations} \alias{data-correlations} \alias{data_correlations_ui} \alias{data_correlations_server} +\alias{data_visuals_ui} +\alias{data_visuals_server} \title{Data correlations evaluation module} \usage{ data_correlations_ui(id, ...) data_correlations_server(id, data, include.class = NULL, cutoff = 0.7, ...) + +data_visuals_ui(id, tab_title = "Plots", ...) + +data_visuals_server(id, data, ...) } \arguments{ \item{id}{Module id. (Use 'ns("id")')} -\item{...}{arguments passed to toastui::datagrid} +\item{...}{ignored} \item{data}{data} @@ -24,8 +30,14 @@ data_correlations_server(id, data, include.class = NULL, cutoff = 0.7, ...) \value{ Shiny ui module +shiny server module + +Shiny ui module + shiny server module } \description{ +Data correlations evaluation module + Data correlations evaluation module } diff --git a/man/data-plots.Rd b/man/data-plots.Rd new file mode 100644 index 0000000..c440b27 --- /dev/null +++ b/man/data-plots.Rd @@ -0,0 +1,70 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data_plots.R +\name{data-plots} +\alias{data-plots} +\alias{plot_ridge} +\alias{create_plot} +\alias{plot_hbars} +\alias{plot_violin} +\alias{plot_scatter} +\alias{plot_sankey} +\title{Title} +\usage{ +plot_ridge(data, x, y, z = NULL, ...) + +create_plot(data, type, x, y, z = NULL, ...) + +plot_hbars(data, x, y, z = NULL) + +plot_violin(data, x, y, z = NULL) + +plot_scatter(data, x, y, z = NULL) + +plot_sankey(data, x, y, z = NULL, color.group = "x", colors = NULL) +} +\arguments{ +\item{...}{ignored for now} + +\item{type}{plot type (derived from possible_plots() and matches custom function)} +} +\value{ +ggplot2 object + +ggplot2 object + +ggplot2 object + +ggplot2 object + +ggplot2 object + +ggplot2 object +} +\description{ +Title + +Wrapper to create plot based on provided type + +Nice horizontal stacked bars (Grotta bars) + +Beatiful violin plot + +Beautiful violin plot + +Beautiful sankey plot with option to split by a tertiary group +} +\examples{ +mtcars |> + default_parsing() |> + plot_ridge(x = "mpg", y = "cyl") +mtcars |> plot_ridge(x = "mpg", y = "cyl", z = "gear") +create_plot(mtcars, "plot_violin", "mpg", "cyl") +mtcars |> plot_hbars(x = "carb", y = "cyl") +mtcars |> plot_hbars(x = "carb", y = NULL) +mtcars |> plot_violin(x = "mpg", y = "cyl", z = "gear") +mtcars |> plot_scatter(x = "mpg", y = "wt") +ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), last = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE))) +ds |> plot_sankey("first", "last") +ds |> plot_sankey("first", "last", color.group = "y") +ds |> plot_sankey("first", "last", z = "g", color.group = "y") +} diff --git a/man/get_label.Rd b/man/get_label.Rd new file mode 100644 index 0000000..579dacc --- /dev/null +++ b/man/get_label.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data_plots.R +\name{get_label} +\alias{get_label} +\title{Print label, and if missing print variable name} +\usage{ +get_label(data, var = NULL) +} +\arguments{ +\item{data}{vector or data frame} +} +\value{ +character string +} +\description{ +Print label, and if missing print variable name +} +\examples{ +mtcars |> get_label(var = "mpg") +mtcars |> get_label() +mtcars$mpg |> get_label() +gtsummary::trial |> get_label(var = "trt") +1:10 |> get_label() +} diff --git a/man/get_plot_options.Rd b/man/get_plot_options.Rd new file mode 100644 index 0000000..08c0449 --- /dev/null +++ b/man/get_plot_options.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data_plots.R +\name{get_plot_options} +\alias{get_plot_options} +\title{Get the function options based on the selected function description} +\usage{ +get_plot_options(data) +} +\arguments{ +\item{data}{vector} +} +\value{ +list +} +\description{ +Get the function options based on the selected function description +} +\examples{ +ls <- mtcars |> + default_parsing() |> + dplyr::pull(mpg) |> + possible_plots() |> + (\(.x){ + .x[[1]] + })() |> + get_plot_options() +} diff --git a/man/is_valid_redcap_url.Rd b/man/is_valid_redcap_url.Rd new file mode 100644 index 0000000..2465cca --- /dev/null +++ b/man/is_valid_redcap_url.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/redcap_read_shiny_module.R +\name{is_valid_redcap_url} +\alias{is_valid_redcap_url} +\title{Title} +\usage{ +is_valid_redcap_url(url) +} +\arguments{ +\item{url}{} +} +\description{ +Title +} +\examples{ +url <- c( + "www.example.com", + "http://example.com", + "https://redcap.your.inst/api/" +) +is_valid_redcap_url(url) +} diff --git a/man/is_valid_token.Rd b/man/is_valid_token.Rd new file mode 100644 index 0000000..335ae74 --- /dev/null +++ b/man/is_valid_token.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/redcap_read_shiny_module.R +\name{is_valid_token} +\alias{is_valid_token} +\title{Validate REDCap token} +\usage{ +is_valid_token(token, pattern_env = NULL, nchar = 32) +} +\arguments{ +\item{token}{token} + +\item{pattern_env}{pattern} +} +\description{ +Validate REDCap token +} +\examples{ +token <- paste(sample(c(1:9, LETTERS[1:6]), 32, TRUE), collapse = "") +is_valid_token(token) +} diff --git a/man/launch.Rd b/man/launch_freesearcheR.Rd similarity index 78% rename from man/launch.Rd rename to man/launch_freesearcheR.Rd index 0d427e8..7ec99f8 100644 --- a/man/launch.Rd +++ b/man/launch_freesearcheR.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/shiny_freesearcheR.R -\name{launch} -\alias{launch} +\name{launch_freesearcheR} +\alias{launch_freesearcheR} \title{Easily launch the freesearcheR app} \usage{ -launch(...) +launch_freesearcheR(...) } \arguments{ \item{...}{passed on to \code{shiny::runApp()}} diff --git a/man/line_break.Rd b/man/line_break.Rd new file mode 100644 index 0000000..886806d --- /dev/null +++ b/man/line_break.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data_plots.R +\name{line_break} +\alias{line_break} +\title{Line breaking at given number of characters for nicely plotting labels} +\usage{ +line_break(data, lineLength = 20) +} +\arguments{ +\item{lineLength}{} +} +\description{ +Line breaking at given number of characters for nicely plotting labels +} diff --git a/man/plot_sankey_single.Rd b/man/plot_sankey_single.Rd new file mode 100644 index 0000000..2f07a7b --- /dev/null +++ b/man/plot_sankey_single.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data_plots.R +\name{plot_sankey_single} +\alias{plot_sankey_single} +\title{Beautiful sankey plot} +\usage{ +plot_sankey_single(data, x, y, color.group = "x", colors = NULL) +} +\arguments{ +\item{colors}{} +} +\value{ +ggplot2 object +} +\description{ +Beautiful sankey plot +} +\examples{ +ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), last = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE))) +ds |> plot_sankey_single("first", "last") +ds |> plot_sankey_single("first", "last", color.group = "y") +} diff --git a/man/possible_plots.Rd b/man/possible_plots.Rd new file mode 100644 index 0000000..28c0b62 --- /dev/null +++ b/man/possible_plots.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data_plots.R +\name{possible_plots} +\alias{possible_plots} +\title{Get possible regression models} +\usage{ +possible_plots(data) +} +\arguments{ +\item{data}{data} +} +\value{ +character vector +} +\description{ +Get possible regression models +} +\examples{ +mtcars |> + default_parsing() |> + dplyr::pull("cyl") |> + possible_plots() + +mtcars |> + default_parsing() |> + dplyr::select("mpg") |> + possible_plots() +} diff --git a/man/redcap_read_shiny_module.Rd b/man/redcap_read_shiny_module.Rd index f72697b..32611be 100644 --- a/man/redcap_read_shiny_module.Rd +++ b/man/redcap_read_shiny_module.Rd @@ -1,30 +1,21 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/redcap_read_shiny_module.R -\docType{data} \name{m_redcap_readUI} \alias{m_redcap_readUI} \alias{m_redcap_readServer} -\alias{tdm_redcap_read} -\alias{redcap_app} +\alias{redcap_demo_app} \title{Shiny module to browser and export REDCap data} -\format{ -An object of class \code{teal_data_module} of length 2. -} \usage{ m_redcap_readUI(id, include_title = TRUE) -m_redcap_readServer(id, output.format = c("df", "teal", "list")) +m_redcap_readServer(id) -tdm_redcap_read - -redcap_app() +redcap_demo_app() } \arguments{ \item{id}{Namespace id} \item{include_title}{logical to include title} - -\item{output.format}{data.frame ("df") or teal data object ("teal")} } \value{ shiny ui element @@ -34,13 +25,10 @@ shiny server module \description{ Shiny module to browser and export REDCap data -REDCap import teal data module - Test app for the redcap_read_shiny_module } \examples{ \dontrun{ -redcap_app() +redcap_demo_app() } } -\keyword{datasets} diff --git a/man/sankey_ready.Rd b/man/sankey_ready.Rd new file mode 100644 index 0000000..29500d0 --- /dev/null +++ b/man/sankey_ready.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data_plots.R +\name{sankey_ready} +\alias{sankey_ready} +\title{Readying data for sankey plot} +\usage{ +sankey_ready(data, x, y, z = NULL, numbers = "count") +} +\arguments{ +\item{z}{} +} +\description{ +Readying data for sankey plot +} +\examples{ +ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), last = sample(c(letters[1:4], NA), 100, TRUE, prob = c(rep(.23, 4), .08))) +ds |> sankey_ready("first", "last") +ds |> sankey_ready("first", "last", numbers = "percentage") +} diff --git a/man/subset_types.Rd b/man/subset_types.Rd new file mode 100644 index 0000000..bd01efe --- /dev/null +++ b/man/subset_types.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data_plots.R +\name{subset_types} +\alias{subset_types} +\title{Easily subset by data type function} +\usage{ +subset_types(data, types, type.fun = outcome_type) +} +\arguments{ +\item{data}{data} + +\item{types}{desired types} + +\item{type.fun}{function to get type. Default is outcome_type} +} +\value{ +vector +} +\description{ +Easily subset by data type function +} +\examples{ +default_parsing(mtcars) |> subset_types("ordinal") +default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal")) +#' default_parsing(mtcars) |> subset_types("factor",class) +} diff --git a/man/supported_plots.Rd b/man/supported_plots.Rd new file mode 100644 index 0000000..c91ad75 --- /dev/null +++ b/man/supported_plots.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data_plots.R +\name{supported_plots} +\alias{supported_plots} +\title{Implemented functions} +\usage{ +supported_plots() +} +\value{ +list +} +\description{ +Library of supported functions. The list name and "descr" element should be +unique for each element on list. +\itemize{ +\item descr: Plot description +\item primary.type: Primary variable data type (continuous, dichotomous or ordinal) +\item secondary.type: Secondary variable data type (continuous, dichotomous or ordinal) +\item secondary.extra: "none" or NULL to have option to choose none. +\item tertiary.type: Tertiary variable data type (continuous, dichotomous or ordinal) +} +} +\examples{ +supported_plots() |> str() +} diff --git a/man/update-factor.Rd b/man/update-factor.Rd new file mode 100644 index 0000000..8f55a58 --- /dev/null +++ b/man/update-factor.Rd @@ -0,0 +1,48 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/update-factor-ext.R +\name{update-factor} +\alias{update-factor} +\alias{update_factor_ui} +\alias{update_factor_server} +\alias{modal_update_factor} +\title{Module to Reorder the Levels of a Factor Variable} +\usage{ +update_factor_ui(id) + +update_factor_server(id, data_r = reactive(NULL)) + +modal_update_factor( + id, + title = i18n("Update levels of a factor"), + easyClose = TRUE, + size = "l", + footer = NULL +) +} +\arguments{ +\item{id}{Module ID.} + +\item{data_r}{A \code{\link[shiny:reactive]{shiny::reactive()}} function returning a \code{data.frame}.} + +\item{title}{An optional title for the dialog.} + +\item{easyClose}{If \code{TRUE}, the modal dialog can be dismissed by +clicking outside the dialog box, or be pressing the Escape key. If +\code{FALSE} (the default), the modal dialog can't be dismissed in those +ways; instead it must be dismissed by clicking on a \code{modalButton()}, or +from a call to \code{\link[shiny:removeModal]{removeModal()}} on the server.} + +\item{size}{One of \code{"s"} for small, \code{"m"} (the default) for medium, +\code{"l"} for large, or \code{"xl"} for extra large. Note that \code{"xl"} only +works with Bootstrap 4 and above (to opt-in to Bootstrap 4+, +pass \code{\link[bslib:bs_theme]{bslib::bs_theme()}} to the \code{theme} argument of a page container +like \code{\link[shiny:fluidPage]{fluidPage()}}).} + +\item{footer}{UI for footer. Use \code{NULL} for no footer.} +} +\value{ +A \code{\link[shiny:reactive]{shiny::reactive()}} function returning the data. +} +\description{ +This module contain an interface to reorder the levels of a factor variable. +} diff --git a/man/vertical_stacked_bars.Rd b/man/vertical_stacked_bars.Rd new file mode 100644 index 0000000..89b355c --- /dev/null +++ b/man/vertical_stacked_bars.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data_plots.R +\name{vertical_stacked_bars} +\alias{vertical_stacked_bars} +\title{Vertical stacked bar plot wrapper} +\usage{ +vertical_stacked_bars( + data, + score = "full_score", + group = "pase_0_q", + strata = NULL, + t.size = 10, + l.color = "black", + l.size = 0.5, + draw.lines = TRUE +) +} +\arguments{ +\item{t.size}{} +} +\description{ +Vertical stacked bar plot wrapper +}