From 652a8ca1b7e3ac4547bdd9c6afee3d06c79b12ac Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Tue, 15 Apr 2025 12:04:32 +0200 Subject: [PATCH 1/4] plots new accept pri, sec and ter arguments instead of x,y,z to avoid confusion. tests, tests, tests --- DESCRIPTION | 3 +- NAMESPACE | 3 +- R/correlations-module.R | 8 +- R/data_plots.R | 145 +- R/plot_box.R | 27 +- R/plot_euler.R | 9 +- R/plot_hbar.R | 8 +- R/plot_sankey.R | 62 +- R/plot_scatter.R | 20 +- R/plot_violin.R | 14 +- man/{allign_axes.Rd => align_axes.Rd} | 10 +- man/argsstring2list.Rd | 4 + man/create_baseline.Rd | 1 + man/data_type_filter.Rd | 9 +- man/expression_string.Rd | 2 +- man/factorize.Rd | 3 + man/line_break.Rd | 4 +- man/remove_empty_attr.Rd | 9 + man/remove_na_attr.Rd | 23 - man/remove_nested_list.Rd | 4 +- man/subset_types.Rd | 2 +- tests/testthat/_snaps/baseline_table.md | 2182 +++++++++++++++++++++ tests/testthat/_snaps/contrast_text.md | 23 + tests/testthat/_snaps/data_plots.md | 160 ++ tests/testthat/_snaps/helpers.md | 532 +++++ tests/testthat/test-correlations-module.R | 17 + tests/testthat/test-custom_SelectInput.R | 82 +- tests/testthat/test-data_plots.R | 86 + 28 files changed, 3274 insertions(+), 178 deletions(-) rename man/{allign_axes.Rd => align_axes.Rd} (65%) delete mode 100644 man/remove_na_attr.Rd create mode 100644 tests/testthat/_snaps/baseline_table.md create mode 100644 tests/testthat/_snaps/contrast_text.md create mode 100644 tests/testthat/_snaps/data_plots.md create mode 100644 tests/testthat/_snaps/helpers.md create mode 100644 tests/testthat/test-correlations-module.R create mode 100644 tests/testthat/test-data_plots.R diff --git a/DESCRIPTION b/DESCRIPTION index 39f91d74..9efc0677 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -80,7 +80,8 @@ Suggests: rsconnect, knitr, rmarkdown, - testthat (>= 3.0.0) + testthat (>= 3.0.0), + shinytest URL: https://github.com/agdamsbo/FreesearchR, https://agdamsbo.github.io/FreesearchR/ BugReports: https://github.com/agdamsbo/FreesearchR/issues VignetteBuilder: knitr diff --git a/NAMESPACE b/NAMESPACE index d1f911b5..e8ca6f0a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -5,8 +5,8 @@ S3method(cut_var,hms) S3method(plot,tbl_regression) export(add_class_icon) export(add_sparkline) +export(align_axes) export(all_but) -export(allign_axes) export(append_column) export(append_list) export(argsstring2list) @@ -95,7 +95,6 @@ export(regression_model_uv_list) export(regression_table) export(remove_empty_attr) export(remove_empty_cols) -export(remove_na_attr) export(remove_nested_list) export(repeated_instruments) export(sankey_ready) diff --git a/R/correlations-module.R b/R/correlations-module.R index adfd0ae9..4d56be19 100644 --- a/R/correlations-module.R +++ b/R/correlations-module.R @@ -46,7 +46,8 @@ data_correlations_server <- function(id, } else { out <- data() } - out |> dplyr::mutate(dplyr::across(tidyselect::everything(),as.numeric)) + # out |> dplyr::mutate(dplyr::across(tidyselect::everything(),as.numeric)) + sapply(data,as.numeric) # as.numeric() }) @@ -100,8 +101,9 @@ data_correlations_server <- function(id, } correlation_pairs <- function(data, threshold = .8) { - data <- data[!sapply(data, is.character)] - data <- data |> dplyr::mutate(dplyr::across(dplyr::where(is.factor), as.numeric)) + data <- as.data.frame(data)[!sapply(as.data.frame(data), is.character)] + data <- sapply(data,\(.x)if (is.factor(.x)) as.numeric(.x) else .x) |> as.data.frame() + # data <- data |> dplyr::mutate(dplyr::across(dplyr::where(is.factor), as.numeric)) cor <- Hmisc::rcorr(as.matrix(data)) r <- cor$r %>% as.table() d <- r |> diff --git a/R/data_plots.R b/R/data_plots.R index a0ab2f00..783a8d4c 100644 --- a/R/data_plots.R +++ b/R/data_plots.R @@ -88,7 +88,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { ), bslib::nav_panel( title = tab_title, - shiny::plotOutput(ns("plot"),height = "70vh"), + shiny::plotOutput(ns("plot"), height = "70vh"), shiny::tags$br(), shiny::tags$br(), shiny::htmlOutput(outputId = ns("code_plot")) @@ -115,7 +115,7 @@ data_visuals_server <- function(id, rv <- shiny::reactiveValues( plot.params = NULL, plot = NULL, - code=NULL + code = NULL ) # ## --- New attempt @@ -216,7 +216,7 @@ data_visuals_server <- function(id, shiny::req(data()) columnSelectInput( inputId = ns("primary"), - col_subset=names(data())[sapply(data(),data_type)!="text"], + col_subset = names(data())[sapply(data(), data_type) != "text"], data = data, placeholder = "Select variable", label = "Response variable", @@ -318,37 +318,30 @@ data_visuals_server <- function(id, shiny::observeEvent(input$act_plot, { - if (NROW(data())>0){ - tryCatch( - { - parameters <- list( - type = rv$plot.params()[["fun"]], - x = input$primary, - y = input$secondary, - z = input$tertiary - ) + if (NROW(data()) > 0) { + tryCatch( + { + parameters <- list( + type = rv$plot.params()[["fun"]], + pri = input$primary, + sec = input$secondary, + ter = input$tertiary + ) - shiny::withProgress(message = "Drawing the plot. Hold tight for a moment..", { - rv$plot <- rlang::exec(create_plot, !!!append_list(data(),parameters,"data")) - # rv$plot <- create_plot( - # data = data(), - # type = rv$plot.params()[["fun"]], - # x = input$primary, - # y = input$secondary, - # z = input$tertiary - # ) - }) + shiny::withProgress(message = "Drawing the plot. Hold tight for a moment..", { + rv$plot <- rlang::exec(create_plot, !!!append_list(data(), parameters, "data")) + }) - rv$code <- glue::glue("FreesearchR::create_plot(data,{list2str(parameters)})") - - }, - # warning = function(warn) { - # showNotification(paste0(warn), type = "warning") - # }, - error = function(err) { - showNotification(paste0(err), type = "err") - } - )} + rv$code <- glue::glue("FreesearchR::create_plot(data,{list2str(parameters)})") + }, + # warning = function(warn) { + # showNotification(paste0(warn), type = "warning") + # }, + error = function(err) { + showNotification(paste0(err), type = "err") + } + ) + } }, ignoreInit = TRUE ) @@ -415,7 +408,7 @@ all_but <- function(data, ...) { #' #' @examples #' default_parsing(mtcars) |> subset_types("ordinal") -#' default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal" ,"categorical")) +#' default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal", "categorical")) #' #' default_parsing(mtcars) |> subset_types("factor",class) subset_types <- function(data, types, type.fun = data_type) { data[sapply(data, type.fun) %in% types] @@ -450,21 +443,21 @@ supported_plots <- function() { fun = "plot_hbars", 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" ,"categorical"), - secondary.type = c("dichotomous", "ordinal" ,"categorical"), + primary.type = c("dichotomous", "ordinal", "categorical"), + secondary.type = c("dichotomous", "ordinal", "categorical"), secondary.multi = FALSE, - tertiary.type = c("dichotomous", "ordinal" ,"categorical"), + tertiary.type = c("dichotomous", "ordinal", "categorical"), secondary.extra = "none" ), plot_violin = list( fun = "plot_violin", descr = "Violin plot", note = "A modern alternative to the classic boxplot to visualise data distribution", - primary.type = c("datatime","continuous", "dichotomous", "ordinal" ,"categorical"), - secondary.type = c("dichotomous", "ordinal" ,"categorical"), + primary.type = c("datatime", "continuous", "dichotomous", "ordinal", "categorical"), + secondary.type = c("dichotomous", "ordinal", "categorical"), secondary.multi = FALSE, secondary.extra = "none", - tertiary.type = c("dichotomous", "ordinal" ,"categorical") + tertiary.type = c("dichotomous", "ordinal", "categorical") ), # plot_ridge = list( # descr = "Ridge plot", @@ -478,30 +471,30 @@ supported_plots <- function() { fun = "plot_sankey", descr = "Sankey plot", note = "A way of visualising change between groups", - primary.type = c("dichotomous", "ordinal" ,"categorical"), - secondary.type = c("dichotomous", "ordinal" ,"categorical"), + primary.type = c("dichotomous", "ordinal", "categorical"), + secondary.type = c("dichotomous", "ordinal", "categorical"), secondary.multi = FALSE, secondary.extra = NULL, - tertiary.type = c("dichotomous", "ordinal" ,"categorical") + tertiary.type = c("dichotomous", "ordinal", "categorical") ), plot_scatter = list( fun = "plot_scatter", descr = "Scatter plot", note = "A classic way of showing the association between to variables", - primary.type = c("datatime","continuous"), - secondary.type = c("datatime","continuous", "ordinal" ,"categorical"), + primary.type = c("datatime", "continuous"), + secondary.type = c("datatime", "continuous", "ordinal", "categorical"), secondary.multi = FALSE, - tertiary.type = c("dichotomous", "ordinal" ,"categorical"), + tertiary.type = c("dichotomous", "ordinal", "categorical"), secondary.extra = NULL ), plot_box = list( fun = "plot_box", descr = "Box plot", note = "A classic way to plot data distribution by groups", - primary.type = c("datatime","continuous", "dichotomous", "ordinal" ,"categorical"), - secondary.type = c("dichotomous", "ordinal" ,"categorical"), + primary.type = c("datatime", "continuous", "dichotomous", "ordinal", "categorical"), + secondary.type = c("dichotomous", "ordinal", "categorical"), secondary.multi = FALSE, - tertiary.type = c("dichotomous", "ordinal" ,"categorical"), + tertiary.type = c("dichotomous", "ordinal", "categorical"), secondary.extra = "none" ), plot_euler = list( @@ -512,7 +505,7 @@ supported_plots <- function() { secondary.type = "dichotomous", secondary.multi = TRUE, secondary.max = 4, - tertiary.type = c("dichotomous", "ordinal" ,"categorical"), + tertiary.type = c("dichotomous", "ordinal", "categorical"), secondary.extra = NULL ) ) @@ -591,9 +584,9 @@ get_plot_options <- function(data) { #' Wrapper to create plot based on provided type #' #' @param data data.frame -#' @param x primary variable -#' @param y secondary variable -#' @param z tertiary variable +#' @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 ... ignored for now #' @@ -603,20 +596,36 @@ get_plot_options <- function(data) { #' @export #' #' @examples -#' create_plot(mtcars, "plot_violin", "mpg", "cyl") -create_plot <- function(data, type, x, y, z = NULL, ...) { - if (!any(y %in% names(data))) { - y <- NULL +#' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() +create_plot <- function(data, type, pri, sec, ter = NULL, ...) { + if (!is.null(sec)) { + if (!any(sec %in% names(data))) { + sec <- NULL + } } - if (!z %in% names(data)) { - z <- NULL + if (!is.null(ter)) { + if (!ter %in% names(data)) { + ter <- NULL + } } - do.call( - type, - list(data, x, y, z, ...) + parameters <- list( + pri = pri, + sec = sec, + ter = ter, + ... ) + + 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 @@ -666,8 +675,8 @@ get_label <- function(data, var = NULL) { #' #' @examples #' "Lorem ipsum... you know the routine" |> line_break() -#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(fixed = TRUE) -line_break <- function(data, lineLength = 20, fixed = FALSE) { +#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE) +line_break <- function(data, lineLength = 20, force = FALSE) { if (isTRUE(force)) { gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), "\\1\n", data) } else { @@ -698,7 +707,7 @@ wrap_plot_list <- function(data, tag_levels = NULL) { .x } })() |> - allign_axes() |> + align_axes() |> patchwork::wrap_plots(guides = "collect", axes = "collect", axis_titles = "collect") if (!is.null(tag_levels)) { out <- out + patchwork::plot_annotation(tag_levels = tag_levels) @@ -713,19 +722,21 @@ wrap_plot_list <- function(data, tag_levels = NULL) { } -#' Alligns axes between plots +#' Aligns axes between plots #' #' @param ... ggplot2 objects or list of ggplot2 objects #' #' @returns list of ggplot2 objects #' @export #' -allign_axes <- function(...) { +align_axes <- function(...) { # 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") @@ -737,7 +748,7 @@ allign_axes <- function(...) { suppressWarnings({ p |> purrr::map(~ .x + ggplot2::xlim(xr) + ggplot2::ylim(yr)) - }) + }) } #' Extract and clean axis ranges diff --git a/R/plot_box.R b/R/plot_box.R index 09ab6c80..45b48860 100644 --- a/R/plot_box.R +++ b/R/plot_box.R @@ -6,13 +6,13 @@ #' @name data-plots #' #' @examples -#' mtcars |> plot_box(x = "mpg", y = "cyl", z = "gear") +#' mtcars |> plot_box(pri = "mpg", sec = "cyl", ter = "gear") #' mtcars |> #' default_parsing() |> -#' plot_box(x = "mpg", y = "cyl", z = "gear") -plot_box <- function(data, x, y, z = NULL) { - if (!is.null(z)) { - ds <- split(data, data[z]) +#' plot_box(pri = "mpg", sec = "cyl", ter = "gear") +plot_box <- function(data, pri, sec, ter = NULL) { + if (!is.null(ter)) { + ds <- split(data, data[ter]) } else { ds <- list(data) } @@ -20,13 +20,12 @@ plot_box <- function(data, x, y, z = NULL) { out <- lapply(ds, \(.ds){ plot_box_single( data = .ds, - x = x, - y = y + pri = pri, + sec = sec ) }) wrap_plot_list(out) - # patchwork::wrap_plots(out,guides = "collect") } @@ -41,18 +40,18 @@ plot_box <- function(data, x, y, z = NULL) { #' #' @examples #' mtcars |> plot_box_single("mpg","cyl") -plot_box_single <- function(data, x, y=NULL, seed = 2103) { +plot_box_single <- function(data, pri, sec=NULL, seed = 2103) { set.seed(seed) - if (is.null(y)) { - y <- "All" - data[[y]] <- y + if (is.null(sec)) { + sec <- "All" + data[[y]] <- sec } - discrete <- !data_type(data[[y]]) %in% "continuous" + discrete <- !data_type(data[[sec]]) %in% "continuous" data |> - ggplot2::ggplot(ggplot2::aes(x = !!dplyr::sym(x), y = !!dplyr::sym(y), fill = !!dplyr::sym(y), group = !!dplyr::sym(y))) + + ggplot2::ggplot(ggplot2::aes(x = !!dplyr::sym(pri), y = !!dplyr::sym(sec), fill = !!dplyr::sym(sec), group = !!dplyr::sym(sec))) + ggplot2::geom_boxplot(linewidth = 1.8, outliers = FALSE) + ## THis could be optional in future ggplot2::geom_jitter(color = "black", size = 2, alpha = 0.9, width = 0.1, height = .5) + diff --git a/R/plot_euler.R b/R/plot_euler.R index 88ce437f..36c8f918 100644 --- a/R/plot_euler.R +++ b/R/plot_euler.R @@ -76,16 +76,16 @@ ggeulerr <- function( #' D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE) #' ) |> plot_euler("A", c("B", "C"), "D", seed = 4) #' mtcars |> plot_euler("vs", "am", seed = 1) -plot_euler <- function(data, x, y, z = NULL, seed = 2103) { +plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) { set.seed(seed = seed) - if (!is.null(z)) { - ds <- split(data, data[z]) + if (!is.null(ter)) { + ds <- split(data, data[ter]) } else { ds <- list(data) } out <- lapply(ds, \(.x){ - .x[c(x, y)] |> + .x[c(pri, sec)] |> as.data.frame() |> plot_euler_single() }) @@ -95,7 +95,6 @@ plot_euler <- function(data, x, y, z = NULL, seed = 2103) { # patchwork::wrap_plots(out, guides = "collect") } -?withCallingHandlers() #' Easily plot single euler diagrams #' #' @returns ggplot2 object diff --git a/R/plot_hbar.R b/R/plot_hbar.R index 4f322fa3..84ead0da 100644 --- a/R/plot_hbar.R +++ b/R/plot_hbar.R @@ -6,10 +6,10 @@ #' @name data-plots #' #' @examples -#' mtcars |> plot_hbars(x = "carb", y = "cyl") -#' mtcars |> plot_hbars(x = "carb", y = NULL) -plot_hbars <- function(data, x, y, z = NULL) { - out <- vertical_stacked_bars(data = data, score = x, group = y, strata = z) +#' mtcars |> plot_hbars(pri = "carb", sec = "cyl") +#' mtcars |> plot_hbars(pri = "carb", sec = NULL) +plot_hbars <- function(data, pri, sec, ter = NULL) { + out <- vertical_stacked_bars(data = data, score = pri, group = sec, strata = ter) out } diff --git a/R/plot_sankey.R b/R/plot_sankey.R index baddb7f9..55a0b4e3 100644 --- a/R/plot_sankey.R +++ b/R/plot_sankey.R @@ -15,42 +15,42 @@ #' last = sample(c(TRUE, FALSE, FALSE), 100, TRUE) #' ) |> #' sankey_ready("first", "last") -sankey_ready <- function(data, x, y, numbers = "count", ...) { +sankey_ready <- function(data, pri, sec, numbers = "count", ...) { ## TODO: Ensure ordering x and y ## Ensure all are factors - data[c(x, y)] <- data[c(x, y)] |> + data[c(pri, sec)] <- data[c(pri, sec)] |> dplyr::mutate(dplyr::across(!dplyr::where(is.factor), forcats::as_factor)) - out <- dplyr::count(data, !!dplyr::sym(x), !!dplyr::sym(y)) + out <- dplyr::count(data, !!dplyr::sym(pri), !!dplyr::sym(sec)) out <- out |> - dplyr::group_by(!!dplyr::sym(x)) |> + dplyr::group_by(!!dplyr::sym(pri)) |> dplyr::mutate(gx.sum = sum(n)) |> dplyr::ungroup() |> - dplyr::group_by(!!dplyr::sym(y)) |> + dplyr::group_by(!!dplyr::sym(sec)) |> 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, ")")) + lx = factor(paste0(!!dplyr::sym(pri), "\n(n=", gx.sum, ")")), + ly = factor(paste0(!!dplyr::sym(sec), "\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), "%)")) + lx = factor(paste0(!!dplyr::sym(pri), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)")), + ly = factor(paste0(!!dplyr::sym(sec), "\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")) + if (is.factor(data[[pri]])) { + index <- match(levels(data[[pri]]), 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")) + if (is.factor(data[[sec]])) { + index <- match(levels(data[[sec]]), str_remove_last(levels(out$ly), "\n")) out$ly <- factor(out$ly, levels = levels(out$ly)[index]) } @@ -75,15 +75,15 @@ str_remove_last <- function(data, pattern = "\n") { #' 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]) +plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "x", colors = NULL) { + if (!is.null(ter)) { + ds <- split(data, data[ter]) } else { ds <- list(data) } out <- lapply(ds, \(.ds){ - plot_sankey_single(.ds, x = x, y = y, color.group = color.group, colors = colors) + plot_sankey_single(.ds, x = pri, y = sec, color.group = color.group, colors = colors) }) patchwork::wrap_plots(out) @@ -112,10 +112,10 @@ default_theme <- function() { #' first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), #' last = sample(c(TRUE, FALSE, FALSE), 100, TRUE) #' ) |> -#' plot_sankey_single("first", "last", color.group = "x") -plot_sankey_single <- function(data, x, y, color.group = c("x", "y"), colors = NULL, ...) { +#' plot_sankey_single("first", "last", color.group = "pri") +plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), colors = NULL, ...) { color.group <- match.arg(color.group) - data <- data |> sankey_ready(x = x, y = y, ...) + data <- data |> sankey_ready(pri = pri, sec = sec, ...) library(ggalluvial) @@ -123,13 +123,13 @@ plot_sankey_single <- function(data, x, y, color.group = c("x", "y"), colors = N 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]]))) + if (color.group == "sec") { + main.colors <- viridisLite::viridis(n = length(levels(data[[sec]]))) + secondary.colors <- rep(na.color, length(levels(data[[pri]]))) 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]]))) + main.colors <- viridisLite::viridis(n = length(levels(data[[pri]]))) + secondary.colors <- rep(na.color, length(levels(data[[sec]]))) label.colors <- Reduce(c, lapply(list(rev(main.colors), secondary.colors), contrast_text)) } colors <- c(na.color, main.colors, secondary.colors) @@ -137,33 +137,33 @@ plot_sankey_single <- function(data, x, y, color.group = c("x", "y"), colors = N label.colors <- contrast_text(colors) } - group_labels <- c(get_label(data, x), get_label(data, y)) |> + group_labels <- c(get_label(data, pri), get_label(data, sec)) |> sapply(line_break) |> unname() p <- ggplot2::ggplot(data, ggplot2::aes(y = n, axis1 = lx, axis2 = ly)) - if (color.group == "y") { + if (color.group == "sec") { p <- p + ggalluvial::geom_alluvium( - ggplot2::aes(fill = !!dplyr::sym(y), color = !!dplyr::sym(y)), + ggplot2::aes(fill = !!dplyr::sym(sec), color = !!dplyr::sym(sec)), width = 1 / 16, alpha = .8, knot.pos = 0.4, curve_type = "sigmoid" - ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(y)), + ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(sec)), size = 2, width = 1 / 3.4 ) } else { p <- p + ggalluvial::geom_alluvium( - ggplot2::aes(fill = !!dplyr::sym(x), color = !!dplyr::sym(x)), + ggplot2::aes(fill = !!dplyr::sym(pri), color = !!dplyr::sym(pri)), width = 1 / 16, alpha = .8, knot.pos = 0.4, curve_type = "sigmoid" - ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(x)), + ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(pri)), size = 2, width = 1 / 3.4 ) diff --git a/R/plot_scatter.R b/R/plot_scatter.R index 8f386719..c2389b08 100644 --- a/R/plot_scatter.R +++ b/R/plot_scatter.R @@ -6,20 +6,24 @@ #' @name data-plots #' #' @examples -#' mtcars |> plot_scatter(x = "mpg", y = "wt") -plot_scatter <- function(data, x, y, z = NULL) { - if (is.null(z)) { +#' mtcars |> plot_scatter(pri = "mpg", sec = "wt") +plot_scatter <- function(data, pri, sec, ter = NULL) { + if (is.null(ter)) { rempsyc::nice_scatter( data = data, - predictor = y, - response = x, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x) + predictor = sec, + response = pri, + xtitle = get_label(data, var = sec), + ytitle = get_label(data, var = pri) ) } else { rempsyc::nice_scatter( data = data, - predictor = y, - response = x, - group = z, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x) + predictor = sec, + response = pri, + group = ter, + xtitle = get_label(data, var = sec), + ytitle = get_label(data, var = pri) ) } } diff --git a/R/plot_violin.R b/R/plot_violin.R index 7feabd72..e6c54346 100644 --- a/R/plot_violin.R +++ b/R/plot_violin.R @@ -6,10 +6,10 @@ #' @name data-plots #' #' @examples -#' mtcars |> plot_violin(x = "mpg", y = "cyl", z = "gear") -plot_violin <- function(data, x, y, z = NULL) { - if (!is.null(z)) { - ds <- split(data, data[z]) +#' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear") +plot_violin <- function(data, pri, sec, ter = NULL) { + if (!is.null(ter)) { + ds <- split(data, data[ter]) } else { ds <- list(data) } @@ -17,8 +17,10 @@ plot_violin <- function(data, x, y, z = NULL) { out <- lapply(ds, \(.ds){ rempsyc::nice_violin( data = .ds, - group = y, - response = x, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x) + group = sec, + response = pri, + xtitle = get_label(data, var = sec), + ytitle = get_label(data, var = pri) ) }) diff --git a/man/allign_axes.Rd b/man/align_axes.Rd similarity index 65% rename from man/allign_axes.Rd rename to man/align_axes.Rd index 5bb4a39e..01a43a3b 100644 --- a/man/allign_axes.Rd +++ b/man/align_axes.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/data_plots.R -\name{allign_axes} -\alias{allign_axes} -\title{Alligns axes between plots} +\name{align_axes} +\alias{align_axes} +\title{Aligns axes between plots} \usage{ -allign_axes(...) +align_axes(...) } \arguments{ \item{...}{ggplot2 objects or list of ggplot2 objects} @@ -13,5 +13,5 @@ allign_axes(...) list of ggplot2 objects } \description{ -Alligns axes between plots +Aligns axes between plots } diff --git a/man/argsstring2list.Rd b/man/argsstring2list.Rd index 48639a0b..70be11c8 100644 --- a/man/argsstring2list.Rd +++ b/man/argsstring2list.Rd @@ -15,3 +15,7 @@ list \description{ Idea from the answer: https://stackoverflow.com/a/62979238 } +\examples{ +argsstring2list("A=1:5,b=2:4") + +} diff --git a/man/create_baseline.Rd b/man/create_baseline.Rd index 11789177..4c13ff3c 100644 --- a/man/create_baseline.Rd +++ b/man/create_baseline.Rd @@ -32,4 +32,5 @@ Create a baseline table } \examples{ mtcars |> create_baseline(by.var = "gear", add.p = "yes" == "yes") +create_baseline(default_parsing(mtcars), by.var = "am", add.p = FALSE, add.overall = FALSE, theme = "lancet") } diff --git a/man/data_type_filter.Rd b/man/data_type_filter.Rd index 4dab22b1..b6c03c07 100644 --- a/man/data_type_filter.Rd +++ b/man/data_type_filter.Rd @@ -18,8 +18,13 @@ data.frame Filter function to filter data set by variable type } \examples{ -default_parsing(mtcars) |> data_type_filter(type=c("categorical","continuous")) |> attributes() +default_parsing(mtcars) |> + data_type_filter(type = c("categorical", "continuous")) |> + attributes() +default_parsing(mtcars) |> + data_type_filter(type = NULL) |> + attributes() \dontrun{ -default_parsing(mtcars) |> data_type_filter(type=c("test","categorical","continuous")) +default_parsing(mtcars) |> data_type_filter(type = c("test", "categorical", "continuous")) } } diff --git a/man/expression_string.Rd b/man/expression_string.Rd index 65e2439c..82719129 100644 --- a/man/expression_string.Rd +++ b/man/expression_string.Rd @@ -17,7 +17,7 @@ Deparses expression as string, substitutes native pipe and adds assign } \examples{ list( -as.symbol(paste0("mtcars$","mpg")), + as.symbol(paste0("mtcars$", "mpg")), rlang::call2(.fn = "select", !!!list(c("cyl", "disp")), .ns = "dplyr"), rlang::call2(.fn = "default_parsing", .ns = "FreesearchR") ) |> diff --git a/man/factorize.Rd b/man/factorize.Rd index d66412ba..1ad79ca3 100644 --- a/man/factorize.Rd +++ b/man/factorize.Rd @@ -17,3 +17,6 @@ data.frame \description{ Factorize variables in data.frame } +\examples{ +factorize(mtcars,names(mtcars)) +} diff --git a/man/line_break.Rd b/man/line_break.Rd index c74ead08..65c987c7 100644 --- a/man/line_break.Rd +++ b/man/line_break.Rd @@ -4,7 +4,7 @@ \alias{line_break} \title{Line breaking at given number of characters for nicely plotting labels} \usage{ -line_break(data, lineLength = 20, fixed = FALSE) +line_break(data, lineLength = 20, force = FALSE) } \arguments{ \item{data}{string} @@ -22,5 +22,5 @@ Line breaking at given number of characters for nicely plotting labels } \examples{ "Lorem ipsum... you know the routine" |> line_break() -paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(fixed = TRUE) +paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE) } diff --git a/man/remove_empty_attr.Rd b/man/remove_empty_attr.Rd index 39f3cc41..68155680 100644 --- a/man/remove_empty_attr.Rd +++ b/man/remove_empty_attr.Rd @@ -15,3 +15,12 @@ data of same class as input \description{ Remove empty/NA attributes } +\examples{ +ds <- mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x, label = NA, attr = "label")) |> dplyr::bind_cols() +ds |> + remove_empty_attr() |> + str() + mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x, label = NA, attr = "label")) |> remove_empty_attr() |> + str() + +} diff --git a/man/remove_na_attr.Rd b/man/remove_na_attr.Rd deleted file mode 100644 index 41bb4ee2..00000000 --- a/man/remove_na_attr.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/helpers.R -\name{remove_na_attr} -\alias{remove_na_attr} -\title{Remove NA labels} -\usage{ -remove_na_attr(data, attr = "label") -} -\arguments{ -\item{data}{data} -} -\value{ -data.frame -} -\description{ -Remove NA labels -} -\examples{ -ds <- mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x, label = NA, attr = "label")) -ds |> - remove_na_attr() |> - str() -} diff --git a/man/remove_nested_list.Rd b/man/remove_nested_list.Rd index 73633191..716a982e 100644 --- a/man/remove_nested_list.Rd +++ b/man/remove_nested_list.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/helpers.R \name{remove_nested_list} \alias{remove_nested_list} -\title{Very simple function to remove nested lists, lik ewhen uploading .rds} +\title{Very simple function to remove nested lists, like when uploading .rds} \usage{ remove_nested_list(data) } @@ -13,7 +13,7 @@ remove_nested_list(data) data.frame } \description{ -Very simple function to remove nested lists, lik ewhen uploading .rds +Very simple function to remove nested lists, like when uploading .rds } \examples{ dplyr::tibble(a = 1:10, b = rep(list("a"), 10)) |> remove_nested_list() diff --git a/man/subset_types.Rd b/man/subset_types.Rd index 7b3f3665..c1a7ef9a 100644 --- a/man/subset_types.Rd +++ b/man/subset_types.Rd @@ -21,6 +21,6 @@ Easily subset by data type function } \examples{ default_parsing(mtcars) |> subset_types("ordinal") -default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal" ,"categorical")) +default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal", "categorical")) #' default_parsing(mtcars) |> subset_types("factor",class) } diff --git a/tests/testthat/_snaps/baseline_table.md b/tests/testthat/_snaps/baseline_table.md new file mode 100644 index 00000000..f5cc8423 --- /dev/null +++ b/tests/testthat/_snaps/baseline_table.md @@ -0,0 +1,2182 @@ +# Creates correct table + + Code + create_baseline(mtcars, by.var = "gear", add.p = "yes" == "yes", add.overall = TRUE, + theme = "lancet") + Message + Setting theme "The Lancet" + Output +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
CharacteristicOverall
+ N = 321		3
+ N = 151		4
+ N = 121		5
+ N = 51		p-value2
mpg19·2 (15·4 – 22·8)15·5 (14·3 – 18·7)22·8 (21·0 – 28·9)19·7 (15·8 – 26·0)0·0008
cyl



<0·0001
    411 (34%)1 (6·7%)8 (67%)2 (40%)
    67 (22%)2 (13%)4 (33%)1 (20%)
    814 (44%)12 (80%)0 (0%)2 (40%)
disp196 (121 – 334)318 (276 – 400)131 (79 – 160)145 (120 – 301)0·0003
hp123 (96 – 180)180 (150 – 215)94 (66 – 110)175 (113 – 264)0·0007
drat3·70 (3·08 – 3·92)3·08 (3·00 – 3·21)3·92 (3·90 – 4·10)3·77 (3·62 – 4·22)<0·0001
wt3·33 (2·54 – 3·65)3·73 (3·44 – 4·07)2·70 (2·07 – 3·17)2·77 (2·14 – 3·17)0·0003
qsec17·71 (16·89 – 18·90)17·42 (17·02 – 18·00)18·76 (18·41 – 19·69)15·50 (14·60 – 16·70)0·0017
vs14 (44%)3 (20%)10 (83%)1 (20%)0·0013
am13 (41%)0 (0%)8 (67%)5 (100%)<0·0001
carb



0·24
    17 (22%)3 (20%)4 (33%)0 (0%)
    210 (31%)4 (27%)4 (33%)2 (40%)
    33 (9·4%)3 (20%)0 (0%)0 (0%)
    410 (31%)5 (33%)4 (33%)1 (20%)
    61 (3·1%)0 (0%)0 (0%)1 (20%)
    81 (3·1%)0 (0%)0 (0%)1 (20%)
1 Median (IQR); n (%)
2 Kruskal-Wallis rank sum test; Fisher’s exact test
+
+ +--- + + Code + create_baseline(mtcars, by.var = "none", add.p = FALSE, add.overall = FALSE, + theme = "lancet") + Message + Setting theme "The Lancet" + Output +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
CharacteristicN = 321
mpg19·2 (15·4 – 22·8)
cyl
    411 (34%)
    67 (22%)
    814 (44%)
disp196 (121 – 334)
hp123 (96 – 180)
drat3·70 (3·08 – 3·92)
wt3·33 (2·54 – 3·65)
qsec17·71 (16·89 – 18·90)
vs14 (44%)
am13 (41%)
gear
    315 (47%)
    412 (38%)
    55 (16%)
carb
    17 (22%)
    210 (31%)
    33 (9·4%)
    410 (31%)
    61 (3·1%)
    81 (3·1%)
1 Median (IQR); n (%)
+
+ +--- + + Code + create_baseline(mtcars, by.var = "test", add.p = FALSE, add.overall = FALSE, + theme = "jama") + Message + Setting theme "JAMA" + Output +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
CharacteristicN = 32
mpg, Median (IQR)19.2 (15.4 – 22.8)
cyl, n (%)
    411 (34)
    67 (22)
    814 (44)
disp, Median (IQR)196 (121 – 334)
hp, Median (IQR)123 (96 – 180)
drat, Median (IQR)3.70 (3.08 – 3.92)
wt, Median (IQR)3.33 (2.54 – 3.65)
qsec, Median (IQR)17.71 (16.89 – 18.90)
vs, n (%)14 (44)
am, n (%)13 (41)
gear, n (%)
    315 (47)
    412 (38)
    55 (16)
carb, n (%)
    17 (22)
    210 (31)
    33 (9.4)
    410 (31)
    61 (3.1)
    81 (3.1)
+
+ +--- + + Code + create_baseline(default_parsing(mtcars), by.var = "am", add.p = FALSE, + add.overall = FALSE, theme = "nejm") + Message + Setting theme "New England Journal of Medicine" + Output +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
CharacteristicFALSE
+ N = 191		TRUE
+ N = 131
mpg17.3 (14.7 – 19.2)22.8 (21.0 – 30.4)
cyl

    43 (16)8 (62)
    64 (21)3 (23)
    812 (63)2 (15)
disp276 (168 – 360)120 (79 – 160)
hp175 (110 – 205)109 (66 – 113)
drat3.15 (3.07 – 3.70)4.08 (3.85 – 4.22)
wt3.52 (3.44 – 3.85)2.32 (1.94 – 2.78)
qsec17.82 (17.05 – 19.44)17.02 (16.46 – 18.61)
vs7 (37)7 (54)
gear

    315 (79)0 (0)
    44 (21)8 (62)
    50 (0)5 (38)
carb

    13 (16)4 (31)
    26 (32)4 (31)
    33 (16)0 (0)
    47 (37)3 (23)
    60 (0)1 (7.7)
    80 (0)1 (7.7)
1 Median (IQR); n (%)
+
+ diff --git a/tests/testthat/_snaps/contrast_text.md b/tests/testthat/_snaps/contrast_text.md new file mode 100644 index 00000000..258000c3 --- /dev/null +++ b/tests/testthat/_snaps/contrast_text.md @@ -0,0 +1,23 @@ +# Contrasting works + + Code + contrast_text(colors) + Output + [1] "black" "white" "white" "white" "black" "white" + +--- + + Code + contrast_text(colors, light_text = "blue", dark_text = "grey10", method = "relative", + threshold = 0.1) + Output + [1] "grey10" "blue" "grey10" "blue" "grey10" "grey10" + +--- + + Code + contrast_text(colors, light_text = "blue", dark_text = "grey10", method = "perceived", + threshold = 0.7) + Output + [1] "grey10" "blue" "blue" "blue" "grey10" "blue" + diff --git a/tests/testthat/_snaps/data_plots.md b/tests/testthat/_snaps/data_plots.md new file mode 100644 index 00000000..6a69f86d --- /dev/null +++ b/tests/testthat/_snaps/data_plots.md @@ -0,0 +1,160 @@ +# all_but works + + Code + all_but(1:10, c(2, 3), 11, 5) + Output + [1] 1 4 6 7 8 9 10 + +# subset_types works + + Code + subset_types(default_parsing(mtcars), "continuous") + Output + # A tibble: 32 x 6 + mpg disp hp drat wt qsec + + 1 21 160 110 3.9 2.62 16.5 + 2 21 160 110 3.9 2.88 17.0 + 3 22.8 108 93 3.85 2.32 18.6 + 4 21.4 258 110 3.08 3.22 19.4 + 5 18.7 360 175 3.15 3.44 17.0 + 6 18.1 225 105 2.76 3.46 20.2 + 7 14.3 360 245 3.21 3.57 15.8 + 8 24.4 147. 62 3.69 3.19 20 + 9 22.8 141. 95 3.92 3.15 22.9 + 10 19.2 168. 123 3.92 3.44 18.3 + # i 22 more rows + +--- + + Code + subset_types(default_parsing(mtcars), c("dichotomous", "ordinal", "categorical")) + Output + # A tibble: 32 x 5 + cyl vs am gear carb + + 1 6 FALSE TRUE 4 4 + 2 6 FALSE TRUE 4 4 + 3 4 TRUE TRUE 4 1 + 4 6 TRUE FALSE 3 1 + 5 8 FALSE FALSE 3 2 + 6 6 TRUE FALSE 3 1 + 7 8 FALSE FALSE 3 4 + 8 4 TRUE FALSE 4 2 + 9 4 TRUE FALSE 4 2 + 10 6 TRUE FALSE 4 4 + # i 22 more rows + +--- + + Code + subset_types(default_parsing(mtcars), "test") + Output + # A tibble: 32 x 0 + +# possible_plots works + + Code + possible_plots(mtcars$mpg) + Output + [1] "Violin plot" "Scatter plot" "Box plot" + +--- + + Code + possible_plots(default_parsing(mtcars)["cyl"]) + Output + [1] "Stacked horizontal bars" "Violin plot" + [3] "Sankey plot" "Box plot" + +# get_plot_options works + + Code + get_plot_options((function(.x) { + .x[[1]] + })(possible_plots(default_parsing(mtcars)["mpg"]))) + Output + $plot_violin + $plot_violin$fun + [1] "plot_violin" + + $plot_violin$descr + [1] "Violin plot" + + $plot_violin$note + [1] "A modern alternative to the classic boxplot to visualise data distribution" + + $plot_violin$primary.type + [1] "datatime" "continuous" "dichotomous" "ordinal" "categorical" + + $plot_violin$secondary.type + [1] "dichotomous" "ordinal" "categorical" + + $plot_violin$secondary.multi + [1] FALSE + + $plot_violin$secondary.extra + [1] "none" + + $plot_violin$tertiary.type + [1] "dichotomous" "ordinal" "categorical" + + + +# get_label works + + Code + get_label(mtcars, var = "mpg") + Output + [1] "mpg" + +--- + + Code + get_label(mtcars) + Output + [1] "mtcars" + +--- + + Code + get_label(mtcars$mpg) + Output + [1] "mtcars$mpg" + +--- + + Code + get_label(gtsummary::trial, var = "trt") + Output + [1] "Chemotherapy Treatment" + +--- + + Code + get_label(1:10) + Output + [1] "1:10" + +# line_break works + + Code + line_break("Lorem ipsum... you know the routine") + Output + [1] "Lorem ipsum... you\nknow the routine" + +--- + + Code + line_break(paste(sample(letters[1:10], 100, TRUE), collapse = ""), force = TRUE, + lineLength = 5) + Output + [1] "cjijd\ncjcfb\nihfgi\nfcffh\neaddf\ngegjb\njeegi\nfdhbe\nbgcac\nibfbe\nejibi\nggedh\ngajhf\ngadca\nijeig\ncieeh\ncah\n" + +--- + + Code + line_break(paste(sample(letters[1:10], 100, TRUE), collapse = ""), force = FALSE) + Output + [1] "idjcgcjceeefchffjdbjafabigaiadcfdcfgfgibibhcjbbbejabddeheafggcgbdfbcbeegijggbibaghfidjgeaefhcadbfjig" + diff --git a/tests/testthat/_snaps/helpers.md b/tests/testthat/_snaps/helpers.md new file mode 100644 index 00000000..312df323 --- /dev/null +++ b/tests/testthat/_snaps/helpers.md @@ -0,0 +1,532 @@ +# getfun works + + Code + getfun("stats::lm") + Output + function (formula, data, subset, weights, na.action, method = "qr", + model = TRUE, x = FALSE, y = FALSE, qr = TRUE, singular.ok = TRUE, + contrasts = NULL, offset, ...) + { + ret.x <- x + ret.y <- y + cl <- match.call() + mf <- match.call(expand.dots = FALSE) + m <- match(c("formula", "data", "subset", "weights", "na.action", + "offset"), names(mf), 0L) + mf <- mf[c(1L, m)] + mf$drop.unused.levels <- TRUE + mf[[1L]] <- quote(stats::model.frame) + mf <- eval(mf, parent.frame()) + if (method == "model.frame") + return(mf) + else if (method != "qr") + warning(gettextf("method = '%s' is not supported. Using 'qr'", + method), domain = NA) + mt <- attr(mf, "terms") + y <- model.response(mf, "numeric") + w <- as.vector(model.weights(mf)) + if (!is.null(w) && !is.numeric(w)) + stop("'weights' must be a numeric vector") + offset <- model.offset(mf) + mlm <- is.matrix(y) + ny <- if (mlm) + nrow(y) + else length(y) + if (!is.null(offset)) { + if (!mlm) + offset <- as.vector(offset) + if (NROW(offset) != ny) + stop(gettextf("number of offsets is %d, should equal %d (number of observations)", + NROW(offset), ny), domain = NA) + } + if (is.empty.model(mt)) { + x <- NULL + z <- list(coefficients = if (mlm) matrix(NA_real_, 0, + ncol(y)) else numeric(), residuals = y, fitted.values = 0 * + y, weights = w, rank = 0L, df.residual = if (!is.null(w)) sum(w != + 0) else ny) + if (!is.null(offset)) { + z$fitted.values <- offset + z$residuals <- y - offset + } + } + else { + x <- model.matrix(mt, mf, contrasts) + z <- if (is.null(w)) + lm.fit(x, y, offset = offset, singular.ok = singular.ok, + ...) + else lm.wfit(x, y, w, offset = offset, singular.ok = singular.ok, + ...) + } + class(z) <- c(if (mlm) "mlm", "lm") + z$na.action <- attr(mf, "na.action") + z$offset <- offset + z$contrasts <- attr(x, "contrasts") + z$xlevels <- .getXlevels(mt, mf) + z$call <- cl + z$terms <- mt + if (model) + z$model <- mf + if (ret.x) + z$x <- x + if (ret.y) + z$y <- y + if (!qr) + z$qr <- NULL + z + } + + + +# argsstring2list works + + Code + argsstring2list("A=1:5,b=2:4") + Output + $A + [1] 1 2 3 4 5 + + $b + [1] 2 3 4 + + +# factorize works + + Code + factorize(mtcars, names(mtcars)) + Output + mpg cyl disp hp drat wt qsec vs am gear carb + Mazda RX4 21 6 160 110 3.9 2.62 16.46 0 1 4 4 + Mazda RX4 Wag 21 6 160 110 3.9 2.875 17.02 0 1 4 4 + Datsun 710 22.8 4 108 93 3.85 2.32 18.61 1 1 4 1 + Hornet 4 Drive 21.4 6 258 110 3.08 3.215 19.44 1 0 3 1 + Hornet Sportabout 18.7 8 360 175 3.15 3.44 17.02 0 0 3 2 + Valiant 18.1 6 225 105 2.76 3.46 20.22 1 0 3 1 + Duster 360 14.3 8 360 245 3.21 3.57 15.84 0 0 3 4 + Merc 240D 24.4 4 146.7 62 3.69 3.19 20 1 0 4 2 + Merc 230 22.8 4 140.8 95 3.92 3.15 22.9 1 0 4 2 + Merc 280 19.2 6 167.6 123 3.92 3.44 18.3 1 0 4 4 + Merc 280C 17.8 6 167.6 123 3.92 3.44 18.9 1 0 4 4 + Merc 450SE 16.4 8 275.8 180 3.07 4.07 17.4 0 0 3 3 + Merc 450SL 17.3 8 275.8 180 3.07 3.73 17.6 0 0 3 3 + Merc 450SLC 15.2 8 275.8 180 3.07 3.78 18 0 0 3 3 + Cadillac Fleetwood 10.4 8 472 205 2.93 5.25 17.98 0 0 3 4 + Lincoln Continental 10.4 8 460 215 3 5.424 17.82 0 0 3 4 + Chrysler Imperial 14.7 8 440 230 3.23 5.345 17.42 0 0 3 4 + Fiat 128 32.4 4 78.7 66 4.08 2.2 19.47 1 1 4 1 + Honda Civic 30.4 4 75.7 52 4.93 1.615 18.52 1 1 4 2 + Toyota Corolla 33.9 4 71.1 65 4.22 1.835 19.9 1 1 4 1 + Toyota Corona 21.5 4 120.1 97 3.7 2.465 20.01 1 0 3 1 + Dodge Challenger 15.5 8 318 150 2.76 3.52 16.87 0 0 3 2 + AMC Javelin 15.2 8 304 150 3.15 3.435 17.3 0 0 3 2 + Camaro Z28 13.3 8 350 245 3.73 3.84 15.41 0 0 3 4 + Pontiac Firebird 19.2 8 400 175 3.08 3.845 17.05 0 0 3 2 + Fiat X1-9 27.3 4 79 66 4.08 1.935 18.9 1 1 4 1 + Porsche 914-2 26 4 120.3 91 4.43 2.14 16.7 0 1 5 2 + Lotus Europa 30.4 4 95.1 113 3.77 1.513 16.9 1 1 5 2 + Ford Pantera L 15.8 8 351 264 4.22 3.17 14.5 0 1 5 4 + Ferrari Dino 19.7 6 145 175 3.62 2.77 15.5 0 1 5 6 + Maserati Bora 15 8 301 335 3.54 3.57 14.6 0 1 5 8 + Volvo 142E 21.4 4 121 109 4.11 2.78 18.6 1 1 4 2 + +# default_parsing works + + Code + default_parsing(mtcars) + Output + # A tibble: 32 x 11 + mpg cyl disp hp drat wt qsec vs am gear carb + + 1 21 6 160 110 3.9 2.62 16.5 FALSE TRUE 4 4 + 2 21 6 160 110 3.9 2.88 17.0 FALSE TRUE 4 4 + 3 22.8 4 108 93 3.85 2.32 18.6 TRUE TRUE 4 1 + 4 21.4 6 258 110 3.08 3.22 19.4 TRUE FALSE 3 1 + 5 18.7 8 360 175 3.15 3.44 17.0 FALSE FALSE 3 2 + 6 18.1 6 225 105 2.76 3.46 20.2 TRUE FALSE 3 1 + 7 14.3 8 360 245 3.21 3.57 15.8 FALSE FALSE 3 4 + 8 24.4 4 147. 62 3.69 3.19 20 TRUE FALSE 4 2 + 9 22.8 4 141. 95 3.92 3.15 22.9 TRUE FALSE 4 2 + 10 19.2 6 168. 123 3.92 3.44 18.3 TRUE FALSE 4 4 + # i 22 more rows + +# remove_empty_attr works + + Code + remove_empty_attr(ds) + Output + $mpg + [1] 21.0 21.0 22.8 21.4 18.7 18.1 14.3 24.4 22.8 19.2 17.8 16.4 17.3 15.2 10.4 + [16] 10.4 14.7 32.4 30.4 33.9 21.5 15.5 15.2 13.3 19.2 27.3 26.0 30.4 15.8 19.7 + [31] 15.0 21.4 + + $cyl + [1] 6 6 4 6 8 6 8 4 4 6 6 8 8 8 8 8 8 4 4 4 4 8 8 8 8 4 4 4 8 6 8 4 + + $disp + [1] 160.0 160.0 108.0 258.0 360.0 225.0 360.0 146.7 140.8 167.6 167.6 275.8 + [13] 275.8 275.8 472.0 460.0 440.0 78.7 75.7 71.1 120.1 318.0 304.0 350.0 + [25] 400.0 79.0 120.3 95.1 351.0 145.0 301.0 121.0 + + $hp + [1] 110 110 93 110 175 105 245 62 95 123 123 180 180 180 205 215 230 66 52 + [20] 65 97 150 150 245 175 66 91 113 264 175 335 109 + + $drat + [1] 3.90 3.90 3.85 3.08 3.15 2.76 3.21 3.69 3.92 3.92 3.92 3.07 3.07 3.07 2.93 + [16] 3.00 3.23 4.08 4.93 4.22 3.70 2.76 3.15 3.73 3.08 4.08 4.43 3.77 4.22 3.62 + [31] 3.54 4.11 + + $wt + [1] 2.620 2.875 2.320 3.215 3.440 3.460 3.570 3.190 3.150 3.440 3.440 4.070 + [13] 3.730 3.780 5.250 5.424 5.345 2.200 1.615 1.835 2.465 3.520 3.435 3.840 + [25] 3.845 1.935 2.140 1.513 3.170 2.770 3.570 2.780 + + $qsec + [1] 16.46 17.02 18.61 19.44 17.02 20.22 15.84 20.00 22.90 18.30 18.90 17.40 + [13] 17.60 18.00 17.98 17.82 17.42 19.47 18.52 19.90 20.01 16.87 17.30 15.41 + [25] 17.05 18.90 16.70 16.90 14.50 15.50 14.60 18.60 + + $vs + [1] 0 0 1 1 0 1 0 1 1 1 1 0 0 0 0 0 0 1 1 1 1 0 0 0 0 1 0 1 0 0 0 1 + + $am + [1] 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 1 1 1 1 1 1 1 + + $gear + [1] 4 4 4 3 3 3 3 4 4 4 4 3 3 3 3 3 3 4 4 4 3 3 3 3 3 4 5 5 5 5 5 4 + + $carb + [1] 4 4 1 1 2 1 4 2 2 4 4 3 3 3 4 4 4 1 2 1 1 2 2 4 2 1 2 2 4 6 8 2 + + +--- + + Code + remove_empty_attr(dplyr::bind_cols(ds)) + Output + # A tibble: 32 x 11 + mpg cyl disp hp drat wt qsec vs am gear carb + + 1 21 6 160 110 3.9 2.62 16.5 0 1 4 4 + 2 21 6 160 110 3.9 2.88 17.0 0 1 4 4 + 3 22.8 4 108 93 3.85 2.32 18.6 1 1 4 1 + 4 21.4 6 258 110 3.08 3.22 19.4 1 0 3 1 + 5 18.7 8 360 175 3.15 3.44 17.0 0 0 3 2 + 6 18.1 6 225 105 2.76 3.46 20.2 1 0 3 1 + 7 14.3 8 360 245 3.21 3.57 15.8 0 0 3 4 + 8 24.4 4 147. 62 3.69 3.19 20 1 0 4 2 + 9 22.8 4 141. 95 3.92 3.15 22.9 1 0 4 2 + 10 19.2 6 168. 123 3.92 3.44 18.3 1 0 4 4 + # i 22 more rows + +--- + + Code + remove_empty_attr(ds[[1]]) + Output + [1] 21.0 21.0 22.8 21.4 18.7 18.1 14.3 24.4 22.8 19.2 17.8 16.4 17.3 15.2 10.4 + [16] 10.4 14.7 32.4 30.4 33.9 21.5 15.5 15.2 13.3 19.2 27.3 26.0 30.4 15.8 19.7 + [31] 15.0 21.4 + +# remove_empty_cols works + + Code + remove_empty_cols(data.frame(a = 1:10, b = NA, c = c(2, NA)), cutoff = 0.5) + Output + a c + 1 1 2 + 2 2 NA + 3 3 2 + 4 4 NA + 5 5 2 + 6 6 NA + 7 7 2 + 8 8 NA + 9 9 2 + 10 10 NA + +# append_list works + + Code + append_list(data.frame(letters[1:20], 1:20), ls_d, "letters") + Output + $letters + letters.1.20. X1.20 + 1 a 1 + 2 b 2 + 3 c 3 + 4 d 4 + 5 e 5 + 6 f 6 + 7 g 7 + 8 h 8 + 9 i 9 + 10 j 10 + 11 k 11 + 12 l 12 + 13 m 13 + 14 n 14 + 15 o 15 + 16 p 16 + 17 q 17 + 18 r 18 + 19 s 19 + 20 t 20 + + +--- + + Code + append_list(letters[1:20], ls_d, "letters") + Output + $letters + [1] "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" "n" "o" "p" "q" "r" "s" + [20] "t" + + +# missing_fraction works + + Code + missing_fraction(c(NA, 1:10, rep(NA, 3))) + Output + [1] 0.2857143 + +# data_description works + + Code + data_description(data.frame(sample(1:8, 20, TRUE), sample(c(1:8, NA), 20, TRUE)), + data_text = "This data") + Output + [1] "This data has 20 observations and 2 variables, with 16 (80%) complete cases." + +# Data type filter works + + Code + data_type_filter(default_parsing(mtcars), type = c("categorical", "continuous")) + Output + # A tibble: 32 x 9 + mpg cyl disp hp drat wt qsec gear carb + + 1 21 6 160 110 3.9 2.62 16.5 4 4 + 2 21 6 160 110 3.9 2.88 17.0 4 4 + 3 22.8 4 108 93 3.85 2.32 18.6 4 1 + 4 21.4 6 258 110 3.08 3.22 19.4 3 1 + 5 18.7 8 360 175 3.15 3.44 17.0 3 2 + 6 18.1 6 225 105 2.76 3.46 20.2 3 1 + 7 14.3 8 360 245 3.21 3.57 15.8 3 4 + 8 24.4 4 147. 62 3.69 3.19 20 4 2 + 9 22.8 4 141. 95 3.92 3.15 22.9 4 2 + 10 19.2 6 168. 123 3.92 3.44 18.3 4 4 + # i 22 more rows + +--- + + Code + data_type_filter(default_parsing(mtcars), type = NULL) + Output + # A tibble: 32 x 11 + mpg cyl disp hp drat wt qsec vs am gear carb + + 1 21 6 160 110 3.9 2.62 16.5 FALSE TRUE 4 4 + 2 21 6 160 110 3.9 2.88 17.0 FALSE TRUE 4 4 + 3 22.8 4 108 93 3.85 2.32 18.6 TRUE TRUE 4 1 + 4 21.4 6 258 110 3.08 3.22 19.4 TRUE FALSE 3 1 + 5 18.7 8 360 175 3.15 3.44 17.0 FALSE FALSE 3 2 + 6 18.1 6 225 105 2.76 3.46 20.2 TRUE FALSE 3 1 + 7 14.3 8 360 245 3.21 3.57 15.8 FALSE FALSE 3 4 + 8 24.4 4 147. 62 3.69 3.19 20 TRUE FALSE 4 2 + 9 22.8 4 141. 95 3.92 3.15 22.9 TRUE FALSE 4 2 + 10 19.2 6 168. 123 3.92 3.44 18.3 TRUE FALSE 4 4 + # i 22 more rows + +# sort_by works + + Code + sort_by(c("Multivariable", "Univariable"), c("Univariable", "Minimal", + "Multivariable")) + Output + [1] "Univariable" NA "Multivariable" + +# if_not_missing works + + Code + if_not_missing(NULL, "new") + Output + [1] "new" + +--- + + Code + if_not_missing(c(2, "a", NA)) + Output + [1] "2" "a" + +--- + + Code + if_not_missing("See") + Output + [1] "See" + +# merge_expression, expression_string and pipe_string works + + Code + merge_expression(list(rlang::call2(.fn = "select", !!!list(c("cyl", "disp")), + .ns = "dplyr"), rlang::call2(.fn = "default_parsing", .ns = "FreesearchR"))) + Output + dplyr::select(c("cyl", "disp")) %>% FreesearchR::default_parsing() + +--- + + Code + expression_string(pipe_string(lapply(list("mtcars", rlang::call2(.fn = "select", + !!!list(c("cyl", "disp")), .ns = "dplyr"), rlang::call2(.fn = "default_parsing", + .ns = "FreesearchR")), expression_string)), "data<-") + Output + [1] "data<-mtcars|>\ndplyr::select(c('cyl','disp'))|>\nFreesearchR::default_parsing()" + +--- + + Code + expression_string(merge_expression(list(as.symbol(paste0("mtcars$", "mpg")), + rlang::call2(.fn = "select", !!!list(c("cyl", "disp")), .ns = "dplyr"), rlang::call2( + .fn = "default_parsing", .ns = "FreesearchR")))) + Output + [1] "mtcars$mpg|>\ndplyr::select(c('cyl','disp'))|>\nFreesearchR::default_parsing()" + +# remove_nested_list works + + Code + remove_nested_list(dplyr::tibble(a = 1:10, b = rep(list("a"), 10))) + Output + # A tibble: 10 x 1 + a + + 1 1 + 2 2 + 3 3 + 4 4 + 5 5 + 6 6 + 7 7 + 8 8 + 9 9 + 10 10 + +--- + + Code + remove_nested_list(as.data.frame(dplyr::tibble(a = 1:10, b = rep(list(c("a", + "b")), 10)))) + Output + a + 1 1 + 2 2 + 3 3 + 4 4 + 5 5 + 6 6 + 7 7 + 8 8 + 9 9 + 10 10 + +# set_column_label works + + Code + set_column_label(set_column_label(set_column_label(mtcars, ls), ls2), ls3) + Output + # A tibble: 32 x 11 + mpg cyl disp hp drat wt qsec vs am gear carb + + 1 21 6 160 110 3.9 2.62 16.5 0 1 4 4 + 2 21 6 160 110 3.9 2.88 17.0 0 1 4 4 + 3 22.8 4 108 93 3.85 2.32 18.6 1 1 4 1 + 4 21.4 6 258 110 3.08 3.22 19.4 1 0 3 1 + 5 18.7 8 360 175 3.15 3.44 17.0 0 0 3 2 + 6 18.1 6 225 105 2.76 3.46 20.2 1 0 3 1 + 7 14.3 8 360 245 3.21 3.57 15.8 0 0 3 4 + 8 24.4 4 147. 62 3.69 3.19 20 1 0 4 2 + 9 22.8 4 141. 95 3.92 3.15 22.9 1 0 4 2 + 10 19.2 6 168. 123 3.92 3.44 18.3 1 0 4 4 + # i 22 more rows + +--- + + Code + expression_string(rlang::expr(FreesearchR::set_column_label(label = !!ls3))) + Output + [1] "FreesearchR::set_column_label(label=c(mpg='',cyl='',disp='',hp='Horses',drat='',wt='',qsec='',vs='',am='',gear='',carb=''))" + +# append_column works + + Code + append_column(dplyr::mutate(mtcars, mpg_cut = mpg), mtcars$mpg, "mpg_cutter") + Output + mpg cyl disp hp drat wt qsec vs am gear carb mpg_cut + Mazda RX4 21.0 6 160.0 110 3.90 2.620 16.46 0 1 4 4 21.0 + Mazda RX4 Wag 21.0 6 160.0 110 3.90 2.875 17.02 0 1 4 4 21.0 + Datsun 710 22.8 4 108.0 93 3.85 2.320 18.61 1 1 4 1 22.8 + Hornet 4 Drive 21.4 6 258.0 110 3.08 3.215 19.44 1 0 3 1 21.4 + Hornet Sportabout 18.7 8 360.0 175 3.15 3.440 17.02 0 0 3 2 18.7 + Valiant 18.1 6 225.0 105 2.76 3.460 20.22 1 0 3 1 18.1 + Duster 360 14.3 8 360.0 245 3.21 3.570 15.84 0 0 3 4 14.3 + Merc 240D 24.4 4 146.7 62 3.69 3.190 20.00 1 0 4 2 24.4 + Merc 230 22.8 4 140.8 95 3.92 3.150 22.90 1 0 4 2 22.8 + Merc 280 19.2 6 167.6 123 3.92 3.440 18.30 1 0 4 4 19.2 + Merc 280C 17.8 6 167.6 123 3.92 3.440 18.90 1 0 4 4 17.8 + Merc 450SE 16.4 8 275.8 180 3.07 4.070 17.40 0 0 3 3 16.4 + Merc 450SL 17.3 8 275.8 180 3.07 3.730 17.60 0 0 3 3 17.3 + Merc 450SLC 15.2 8 275.8 180 3.07 3.780 18.00 0 0 3 3 15.2 + Cadillac Fleetwood 10.4 8 472.0 205 2.93 5.250 17.98 0 0 3 4 10.4 + Lincoln Continental 10.4 8 460.0 215 3.00 5.424 17.82 0 0 3 4 10.4 + Chrysler Imperial 14.7 8 440.0 230 3.23 5.345 17.42 0 0 3 4 14.7 + Fiat 128 32.4 4 78.7 66 4.08 2.200 19.47 1 1 4 1 32.4 + Honda Civic 30.4 4 75.7 52 4.93 1.615 18.52 1 1 4 2 30.4 + Toyota Corolla 33.9 4 71.1 65 4.22 1.835 19.90 1 1 4 1 33.9 + Toyota Corona 21.5 4 120.1 97 3.70 2.465 20.01 1 0 3 1 21.5 + Dodge Challenger 15.5 8 318.0 150 2.76 3.520 16.87 0 0 3 2 15.5 + AMC Javelin 15.2 8 304.0 150 3.15 3.435 17.30 0 0 3 2 15.2 + Camaro Z28 13.3 8 350.0 245 3.73 3.840 15.41 0 0 3 4 13.3 + Pontiac Firebird 19.2 8 400.0 175 3.08 3.845 17.05 0 0 3 2 19.2 + Fiat X1-9 27.3 4 79.0 66 4.08 1.935 18.90 1 1 4 1 27.3 + Porsche 914-2 26.0 4 120.3 91 4.43 2.140 16.70 0 1 5 2 26.0 + Lotus Europa 30.4 4 95.1 113 3.77 1.513 16.90 1 1 5 2 30.4 + Ford Pantera L 15.8 8 351.0 264 4.22 3.170 14.50 0 1 5 4 15.8 + Ferrari Dino 19.7 6 145.0 175 3.62 2.770 15.50 0 1 5 6 19.7 + Maserati Bora 15.0 8 301.0 335 3.54 3.570 14.60 0 1 5 8 15.0 + Volvo 142E 21.4 4 121.0 109 4.11 2.780 18.60 1 1 4 2 21.4 + mpg_cutter + Mazda RX4 21.0 + Mazda RX4 Wag 21.0 + Datsun 710 22.8 + Hornet 4 Drive 21.4 + Hornet Sportabout 18.7 + Valiant 18.1 + Duster 360 14.3 + Merc 240D 24.4 + Merc 230 22.8 + Merc 280 19.2 + Merc 280C 17.8 + Merc 450SE 16.4 + Merc 450SL 17.3 + Merc 450SLC 15.2 + Cadillac Fleetwood 10.4 + Lincoln Continental 10.4 + Chrysler Imperial 14.7 + Fiat 128 32.4 + Honda Civic 30.4 + Toyota Corolla 33.9 + Toyota Corona 21.5 + Dodge Challenger 15.5 + AMC Javelin 15.2 + Camaro Z28 13.3 + Pontiac Firebird 19.2 + Fiat X1-9 27.3 + Porsche 914-2 26.0 + Lotus Europa 30.4 + Ford Pantera L 15.8 + Ferrari Dino 19.7 + Maserati Bora 15.0 + Volvo 142E 21.4 + diff --git a/tests/testthat/test-correlations-module.R b/tests/testthat/test-correlations-module.R new file mode 100644 index 00000000..30478c13 --- /dev/null +++ b/tests/testthat/test-correlations-module.R @@ -0,0 +1,17 @@ +test_that("correlations module works", { + testServer(data_correlations_server, args=list(data = mtcars,cutoff = shiny::reactive(.8)), { + expect_equal(nchar(output$suggest), 281) + expect_equal(class(output$correlation_plot),"list") + expect_equal(length(output$correlation_plot),5) + }) + + expect_snapshot( + correlation_pairs(data = gtsummary::trial,threshold = .2) + ) + + expect_snapshot( + sentence_paste(letters[1:8]) + ) + +}) + diff --git a/tests/testthat/test-custom_SelectInput.R b/tests/testthat/test-custom_SelectInput.R index 044a8bac..6c8bb33b 100644 --- a/tests/testthat/test-custom_SelectInput.R +++ b/tests/testthat/test-custom_SelectInput.R @@ -1,3 +1,83 @@ test_that("Create columnSelectInput", { - expect_snapshot(columnSelectInput("x",label = "X",data = mtcars)) + library(shiny) + ui <- shiny::fluidPage( + shiny::uiOutput("x"), + shiny::uiOutput("out") + ) + server <- function(input, output, session) { + library(FreesearchR) + output$x <- + shiny::renderUI({ + columnSelectInput(inputId = "x",selected = "mpg",label = "X",data = mtcars) + }) + + output$out <- renderText({ + # req(input$x) + input$x + }) + } + + # shinyApp(ui,server) + + testServer(server, { + session$setInputs(x = "cyl") + expect_equal(output$out, "cyl") + + session$setInputs(x = "mpg") + expect_equal(output$out, "mpg") + }) + + server <- function(input, output, session) { + library(FreesearchR) + output$x <- + shiny::renderUI({ + columnSelectInput(inputId = "x",label = "X",data = gtsummary::trial) + }) + + output$out <- renderText({ + # req(input$x) + input$x + }) + } + + # shinyApp(ui,server) + + testServer(server, { + session$setInputs(x = "trt") + expect_equal(output$out, "trt") + + session$setInputs(x = "stage") + expect_equal(output$out, "stage") + }) + +}) + +test_that("Create columnSelectInput", { + library(shiny) + ui <- shiny::fluidPage( + shiny::uiOutput("x"), + shiny::uiOutput("out") + ) + server <- function(input, output, session) { + library(FreesearchR) + output$x <- + shiny::renderUI({ + vectorSelectInput(inputId = "x",choices = setNames(names(mtcars),seq_len(ncol(mtcars))),label = "X") + }) + + output$out <- renderText({ + # req(input$x) + input$x + }) + } + + # shinyApp(ui,server) + + testServer(server, { + session$setInputs(x = "cyl") + expect_equal(output$out, "cyl") + + session$setInputs(x = "mpg") + expect_equal(output$out, "mpg") + }) }) diff --git a/tests/testthat/test-data_plots.R b/tests/testthat/test-data_plots.R new file mode 100644 index 00000000..247a8eef --- /dev/null +++ b/tests/testthat/test-data_plots.R @@ -0,0 +1,86 @@ +## all_but +test_that("all_but works", { + expect_snapshot(all_but(1:10, c(2, 3), 11, 5)) +}) + +## subset_types +test_that("subset_types works", { + expect_snapshot( + default_parsing(mtcars) |> subset_types("continuous") + ) + expect_snapshot( + default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal", "categorical")) + ) + expect_snapshot( + default_parsing(mtcars) |> subset_types("test") + ) +}) + +## supported_plots +test_that("supported_plots works", { + expect_true(is.list(supported_plots())) +}) + +## possible_plots +test_that("possible_plots works", { + expect_snapshot(possible_plots(mtcars$mpg)) + + expect_snapshot(default_parsing(mtcars)["cyl"] |> + possible_plots()) +}) + +## get_plot_options +test_that("get_plot_options works", { + expect_snapshot(default_parsing(mtcars)["mpg"] |> + possible_plots() |> + (\(.x){ + .x[[1]] + })() |> + get_plot_options()) +}) + +## create_plot and friends +test_that("create_plot works", { + + ## Violin + p_list <- create_plot(mtcars, type = "plot_violin", pri = "mpg", sec = "cyl", ter = "am") + p <- p_list[[1]] + ggplot2::labs(title = "Test plot") + + expect_equal(length(p_list), 2) + expect_true(ggplot2::is.ggplot(p)) + + # Includes helper functions + # wrap_plot_list + # align_axes + # clean_common_axis + + ## Scatter + p_list <- list( + create_plot(mtcars, type = "plot_scatter", pri = "mpg", sec = "cyl"), + create_plot(mtcars, type = "plot_scatter", pri = "mpg", sec = "cyl", ter = "am") + ) + + lapply(p_list, \(.x){ + expect_true(ggplot2::is.ggplot(.x)) + }) + + purrr::map2(p_list, list(11, 11), \(.x, .y){ + expect_equal(length(.x), .y) + }) +}) + +## get_label +test_that("get_label works", { + expect_snapshot(mtcars |> get_label(var = "mpg")) + expect_snapshot(mtcars |> get_label()) + expect_snapshot(mtcars$mpg |> get_label()) + expect_snapshot(gtsummary::trial |> get_label(var = "trt")) + expect_snapshot(1:10 |> get_label()) +}) + +## line_break +test_that("line_break works", { + expect_snapshot("Lorem ipsum... you know the routine" |> line_break()) + expect_snapshot(paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE, lineLength = 5)) + expect_snapshot(paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = FALSE)) +}) From 50d35c0c8573847108f13efc888d42f8834c6876 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Tue, 15 Apr 2025 16:14:03 +0200 Subject: [PATCH 2/4] data type icons in summary - more tests --- DESCRIPTION | 3 +- R/app_version.R | 2 +- R/baseline_table.R | 2 +- R/cut-variable-dates.R | 33 +- R/data-summary.R | 101 +- R/helpers.R | 2 +- inst/apps/FreesearchR/app.R | 430 +++-- man/data-plots.Rd | 36 +- man/plot_euler.Rd | 6 +- man/plot_sankey_single.Rd | 11 +- tests/testthat.R | 1 + tests/testthat/_snaps/baseline_table.md | 2182 ---------------------- tests/testthat/test-baseline_table.R | 48 +- tests/testthat/test-cut-variable-dates.R | 47 + tests/testthat/test-data_plots.R | 5 +- 15 files changed, 411 insertions(+), 2498 deletions(-) delete mode 100644 tests/testthat/_snaps/baseline_table.md create mode 100644 tests/testthat/test-cut-variable-dates.R diff --git a/DESCRIPTION b/DESCRIPTION index 9efc0677..a951fca0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -81,7 +81,8 @@ Suggests: knitr, rmarkdown, testthat (>= 3.0.0), - shinytest + shinytest, + covr URL: https://github.com/agdamsbo/FreesearchR, https://agdamsbo.github.io/FreesearchR/ BugReports: https://github.com/agdamsbo/FreesearchR/issues VignetteBuilder: knitr diff --git a/R/app_version.R b/R/app_version.R index 09283d38..c47f954b 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'Version: 25.4.3.250414_1342' +app_version <- function()'Version: 25.4.3.250415_1539' diff --git a/R/baseline_table.R b/R/baseline_table.R index 4eaccde4..ecab00b8 100644 --- a/R/baseline_table.R +++ b/R/baseline_table.R @@ -49,7 +49,7 @@ create_baseline <- function(data, ..., by.var, add.p = FALSE, add.overall = FALS } } - gtsummary::theme_gtsummary_journal(journal = theme) + suppressMessages(gtsummary::theme_gtsummary_journal(journal = theme)) args <- list(...) diff --git a/R/cut-variable-dates.R b/R/cut-variable-dates.R index 240d7551..e18f6150 100644 --- a/R/cut-variable-dates.R +++ b/R/cut-variable-dates.R @@ -18,7 +18,7 @@ cut_var <- function(x, ...) { #' @export #' @name cut_var cut_var.default <- function(x, ...) { - base::cut.default(x, ...) + base::cut(x, ...) } #' @name cut_var @@ -581,36 +581,6 @@ modal_cut_variable <- function(id, } -#' @inheritParams shinyWidgets::WinBox -#' @export -#' -#' @importFrom shinyWidgets WinBox wbOptions wbControls -#' @importFrom htmltools tagList -#' @rdname cut-variable -winbox_cut_variable <- function(id, - title = i18n("Convert Numeric to Factor"), - options = shinyWidgets::wbOptions(), - controls = shinyWidgets::wbControls()) { - ns <- NS(id) - WinBox( - title = title, - ui = tagList( - cut_variable_ui(id), - tags$div( - style = "display: none;", - textInput(inputId = ns("hidden"), label = NULL, value = genId()) - ) - ), - options = modifyList( - shinyWidgets::wbOptions(height = "750px", modal = TRUE), - options - ), - controls = controls, - auto_height = FALSE - ) -} - - #' @importFrom graphics abline axis hist par plot.new plot.window plot_histogram <- function(data, column, bins = 30, breaks = NULL, color = "#112466") { x <- data[[column]] @@ -627,3 +597,4 @@ plot_histogram <- function(data, column, bins = 30, breaks = NULL, color = "#112 abline(v = breaks, col = "#FFFFFF", lty = 1, lwd = 1.5) abline(v = breaks, col = "#2E2E2E", lty = 2, lwd = 1.5) } + diff --git a/R/data-summary.R b/R/data-summary.R index b3aff31d..f3f3bfbb 100644 --- a/R/data-summary.R +++ b/R/data-summary.R @@ -155,8 +155,8 @@ overview_vars <- function(data) { data <- as.data.frame(data) dplyr::tibble( - class = get_classes(data), - type = data_type(data), + icon = data_type(data), + type = icon, name = names(data), n_missing = unname(colSums(is.na(data))), p_complete = 1 - n_missing / nrow(data), @@ -188,7 +188,7 @@ create_overview_datagrid <- function(data,...) { std_names <- c( "Name" = "name", - "Class" = "class", + "Icon" = "icon", "Type" = "type", "Missings" = "n_missing", "Complete" = "p_complete", @@ -226,7 +226,7 @@ create_overview_datagrid <- function(data,...) { grid <- toastui::grid_columns( grid = grid, - columns = "class", + columns = "icon", header = " ", align = "center",sortable = FALSE, width = 40 @@ -234,7 +234,8 @@ create_overview_datagrid <- function(data,...) { grid <- add_class_icon( grid = grid, - column = "class" + column = "icon", + fun = type_icons ) grid <- toastui::grid_format( @@ -271,32 +272,14 @@ create_overview_datagrid <- function(data,...) { #' overview_vars() |> #' toastui::datagrid() |> #' add_class_icon() -add_class_icon <- function(grid, column = "class") { +add_class_icon <- function(grid, column = "class", fun=class_icons) { out <- toastui::grid_format( grid = grid, column = column, formatter = function(value) { lapply( X = value, - FUN = function(x) { - if (identical(x, "numeric")) { - shiny::icon("calculator") - } else if (identical(x, "factor")) { - shiny::icon("chart-simple") - } else if (identical(x, "integer")) { - shiny::icon("arrow-down-1-9") - } else if (identical(x, "character")) { - shiny::icon("arrow-down-a-z") - } else if (identical(x, "logical")) { - shiny::icon("toggle-off") - } else if (any(c("Date", "POSIXct", "POSIXt") %in% x)) { - shiny::icon("calendar-days") - } else if ("hms" %in% x) { - shiny::icon("clock") - } else { - shiny::icon("table") - } - } + FUN = fun ) } ) @@ -308,3 +291,71 @@ add_class_icon <- function(grid, column = "class") { width = 60 ) } + + +#' Get data class icons +#' +#' @param x character vector of data classes +#' +#' @returns +#' @export +#' +#' @examples +#' "numeric" |> class_icons() +#' default_parsing(mtcars) |> sapply(class) |> class_icons() +class_icons <- function(x) { + if (length(x)>1){ + sapply(x,class_icons) + } else { + if (identical(x, "numeric")) { + shiny::icon("calculator") + } else if (identical(x, "factor")) { + shiny::icon("chart-simple") + } else if (identical(x, "integer")) { + shiny::icon("arrow-down-1-9") + } else if (identical(x, "character")) { + shiny::icon("arrow-down-a-z") + } else if (identical(x, "logical")) { + shiny::icon("toggle-off") + } else if (any(c("Date", "POSIXct", "POSIXt") %in% x)) { + shiny::icon("calendar-days") + } else if ("hms" %in% x) { + shiny::icon("clock") + } else { + shiny::icon("table") + }} +} + +#' Get data type icons +#' +#' @param x character vector of data classes +#' +#' @returns +#' @export +#' +#' @examples +#' "ordinal" |> type_icons() +#' default_parsing(mtcars) |> sapply(data_type) |> type_icons() +type_icons <- function(x) { + if (length(x)>1){ + sapply(x,class_icons) + } else { + if (identical(x, "continuous")) { + shiny::icon("calculator") + } else if (identical(x, "categorical")) { + shiny::icon("chart-simple") + } else if (identical(x, "ordinal")) { + shiny::icon("arrow-down-1-9") + } else if (identical(x, "text")) { + shiny::icon("arrow-down-a-z") + } else if (identical(x, "dichotomous")) { + shiny::icon("toggle-off") + } else if (identical(x,"datetime")) { + shiny::icon("calendar-days") + } else if (identical(x,"id")) { + shiny::icon("id-card") + } else { + shiny::icon("table") + } + } +} diff --git a/R/helpers.R b/R/helpers.R index 125c3e37..d906c766 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -357,7 +357,7 @@ data_description <- function(data, data_text = "Data") { p_complete <- n_complete / n sprintf( - i18n("%s has %s observations and %s variables, with %s (%s%%) complete cases."), + "%s has %s observations and %s variables, with %s (%s%%) complete cases.", data_text, n, n_var, diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index 85aef6bc..9c0184b9 100644 --- a/inst/apps/FreesearchR/app.R +++ b/inst/apps/FreesearchR/app.R @@ -10,7 +10,7 @@ #### Current file: /Users/au301842/FreesearchR/R//app_version.R ######## -app_version <- function()'Version: 25.4.3.250414_1342' +app_version <- function()'Version: 25.4.3.250415_1539' ######## @@ -68,7 +68,7 @@ create_baseline <- function(data, ..., by.var, add.p = FALSE, add.overall = FALS } } - gtsummary::theme_gtsummary_journal(journal = theme) + suppressMessages(gtsummary::theme_gtsummary_journal(journal = theme)) args <- list(...) @@ -207,7 +207,8 @@ data_correlations_server <- function(id, } else { out <- data() } - out |> dplyr::mutate(dplyr::across(tidyselect::everything(),as.numeric)) + # out |> dplyr::mutate(dplyr::across(tidyselect::everything(),as.numeric)) + sapply(data,as.numeric) # as.numeric() }) @@ -261,8 +262,9 @@ data_correlations_server <- function(id, } correlation_pairs <- function(data, threshold = .8) { - data <- data[!sapply(data, is.character)] - data <- data |> dplyr::mutate(dplyr::across(dplyr::where(is.factor), as.numeric)) + data <- as.data.frame(data)[!sapply(as.data.frame(data), is.character)] + data <- sapply(data,\(.x)if (is.factor(.x)) as.numeric(.x) else .x) |> as.data.frame() + # data <- data |> dplyr::mutate(dplyr::across(dplyr::where(is.factor), as.numeric)) cor <- Hmisc::rcorr(as.matrix(data)) r <- cor$r %>% as.table() d <- r |> @@ -516,7 +518,7 @@ cut_var <- function(x, ...) { #' @export #' @name cut_var cut_var.default <- function(x, ...) { - base::cut.default(x, ...) + base::cut(x, ...) } #' @name cut_var @@ -1079,36 +1081,6 @@ modal_cut_variable <- function(id, } -#' @inheritParams shinyWidgets::WinBox -#' @export -#' -#' @importFrom shinyWidgets WinBox wbOptions wbControls -#' @importFrom htmltools tagList -#' @rdname cut-variable -winbox_cut_variable <- function(id, - title = i18n("Convert Numeric to Factor"), - options = shinyWidgets::wbOptions(), - controls = shinyWidgets::wbControls()) { - ns <- NS(id) - WinBox( - title = title, - ui = tagList( - cut_variable_ui(id), - tags$div( - style = "display: none;", - textInput(inputId = ns("hidden"), label = NULL, value = genId()) - ) - ), - options = modifyList( - shinyWidgets::wbOptions(height = "750px", modal = TRUE), - options - ), - controls = controls, - auto_height = FALSE - ) -} - - #' @importFrom graphics abline axis hist par plot.new plot.window plot_histogram <- function(data, column, bins = 30, breaks = NULL, color = "#112466") { x <- data[[column]] @@ -1127,6 +1099,7 @@ plot_histogram <- function(data, column, bins = 30, breaks = NULL, color = "#112 } + ######## #### Current file: /Users/au301842/FreesearchR/R//data_plots.R ######## @@ -1221,7 +1194,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) { ), bslib::nav_panel( title = tab_title, - shiny::plotOutput(ns("plot"),height = "70vh"), + shiny::plotOutput(ns("plot"), height = "70vh"), shiny::tags$br(), shiny::tags$br(), shiny::htmlOutput(outputId = ns("code_plot")) @@ -1248,7 +1221,7 @@ data_visuals_server <- function(id, rv <- shiny::reactiveValues( plot.params = NULL, plot = NULL, - code=NULL + code = NULL ) # ## --- New attempt @@ -1349,7 +1322,7 @@ data_visuals_server <- function(id, shiny::req(data()) columnSelectInput( inputId = ns("primary"), - col_subset=names(data())[sapply(data(),data_type)!="text"], + col_subset = names(data())[sapply(data(), data_type) != "text"], data = data, placeholder = "Select variable", label = "Response variable", @@ -1451,37 +1424,30 @@ data_visuals_server <- function(id, shiny::observeEvent(input$act_plot, { - if (NROW(data())>0){ - tryCatch( - { - parameters <- list( - type = rv$plot.params()[["fun"]], - x = input$primary, - y = input$secondary, - z = input$tertiary - ) + if (NROW(data()) > 0) { + tryCatch( + { + parameters <- list( + type = rv$plot.params()[["fun"]], + pri = input$primary, + sec = input$secondary, + ter = input$tertiary + ) - shiny::withProgress(message = "Drawing the plot. Hold tight for a moment..", { - rv$plot <- rlang::exec(create_plot, !!!append_list(data(),parameters,"data")) - # rv$plot <- create_plot( - # data = data(), - # type = rv$plot.params()[["fun"]], - # x = input$primary, - # y = input$secondary, - # z = input$tertiary - # ) - }) + shiny::withProgress(message = "Drawing the plot. Hold tight for a moment..", { + rv$plot <- rlang::exec(create_plot, !!!append_list(data(), parameters, "data")) + }) - rv$code <- glue::glue("FreesearchR::create_plot(data,{list2str(parameters)})") - - }, - # warning = function(warn) { - # showNotification(paste0(warn), type = "warning") - # }, - error = function(err) { - showNotification(paste0(err), type = "err") - } - )} + rv$code <- glue::glue("FreesearchR::create_plot(data,{list2str(parameters)})") + }, + # warning = function(warn) { + # showNotification(paste0(warn), type = "warning") + # }, + error = function(err) { + showNotification(paste0(err), type = "err") + } + ) + } }, ignoreInit = TRUE ) @@ -1548,7 +1514,7 @@ all_but <- function(data, ...) { #' #' @examples #' default_parsing(mtcars) |> subset_types("ordinal") -#' default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal" ,"categorical")) +#' default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal", "categorical")) #' #' default_parsing(mtcars) |> subset_types("factor",class) subset_types <- function(data, types, type.fun = data_type) { data[sapply(data, type.fun) %in% types] @@ -1583,21 +1549,21 @@ supported_plots <- function() { fun = "plot_hbars", 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" ,"categorical"), - secondary.type = c("dichotomous", "ordinal" ,"categorical"), + primary.type = c("dichotomous", "ordinal", "categorical"), + secondary.type = c("dichotomous", "ordinal", "categorical"), secondary.multi = FALSE, - tertiary.type = c("dichotomous", "ordinal" ,"categorical"), + tertiary.type = c("dichotomous", "ordinal", "categorical"), secondary.extra = "none" ), plot_violin = list( fun = "plot_violin", descr = "Violin plot", note = "A modern alternative to the classic boxplot to visualise data distribution", - primary.type = c("datatime","continuous", "dichotomous", "ordinal" ,"categorical"), - secondary.type = c("dichotomous", "ordinal" ,"categorical"), + primary.type = c("datatime", "continuous", "dichotomous", "ordinal", "categorical"), + secondary.type = c("dichotomous", "ordinal", "categorical"), secondary.multi = FALSE, secondary.extra = "none", - tertiary.type = c("dichotomous", "ordinal" ,"categorical") + tertiary.type = c("dichotomous", "ordinal", "categorical") ), # plot_ridge = list( # descr = "Ridge plot", @@ -1611,30 +1577,30 @@ supported_plots <- function() { fun = "plot_sankey", descr = "Sankey plot", note = "A way of visualising change between groups", - primary.type = c("dichotomous", "ordinal" ,"categorical"), - secondary.type = c("dichotomous", "ordinal" ,"categorical"), + primary.type = c("dichotomous", "ordinal", "categorical"), + secondary.type = c("dichotomous", "ordinal", "categorical"), secondary.multi = FALSE, secondary.extra = NULL, - tertiary.type = c("dichotomous", "ordinal" ,"categorical") + tertiary.type = c("dichotomous", "ordinal", "categorical") ), plot_scatter = list( fun = "plot_scatter", descr = "Scatter plot", note = "A classic way of showing the association between to variables", - primary.type = c("datatime","continuous"), - secondary.type = c("datatime","continuous", "ordinal" ,"categorical"), + primary.type = c("datatime", "continuous"), + secondary.type = c("datatime", "continuous", "ordinal", "categorical"), secondary.multi = FALSE, - tertiary.type = c("dichotomous", "ordinal" ,"categorical"), + tertiary.type = c("dichotomous", "ordinal", "categorical"), secondary.extra = NULL ), plot_box = list( fun = "plot_box", descr = "Box plot", note = "A classic way to plot data distribution by groups", - primary.type = c("datatime","continuous", "dichotomous", "ordinal" ,"categorical"), - secondary.type = c("dichotomous", "ordinal" ,"categorical"), + primary.type = c("datatime", "continuous", "dichotomous", "ordinal", "categorical"), + secondary.type = c("dichotomous", "ordinal", "categorical"), secondary.multi = FALSE, - tertiary.type = c("dichotomous", "ordinal" ,"categorical"), + tertiary.type = c("dichotomous", "ordinal", "categorical"), secondary.extra = "none" ), plot_euler = list( @@ -1645,7 +1611,7 @@ supported_plots <- function() { secondary.type = "dichotomous", secondary.multi = TRUE, secondary.max = 4, - tertiary.type = c("dichotomous", "ordinal" ,"categorical"), + tertiary.type = c("dichotomous", "ordinal", "categorical"), secondary.extra = NULL ) ) @@ -1724,9 +1690,9 @@ get_plot_options <- function(data) { #' Wrapper to create plot based on provided type #' #' @param data data.frame -#' @param x primary variable -#' @param y secondary variable -#' @param z tertiary variable +#' @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 ... ignored for now #' @@ -1736,20 +1702,36 @@ get_plot_options <- function(data) { #' @export #' #' @examples -#' create_plot(mtcars, "plot_violin", "mpg", "cyl") -create_plot <- function(data, type, x, y, z = NULL, ...) { - if (!any(y %in% names(data))) { - y <- NULL +#' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() +create_plot <- function(data, type, pri, sec, ter = NULL, ...) { + if (!is.null(sec)) { + if (!any(sec %in% names(data))) { + sec <- NULL + } } - if (!z %in% names(data)) { - z <- NULL + if (!is.null(ter)) { + if (!ter %in% names(data)) { + ter <- NULL + } } - do.call( - type, - list(data, x, y, z, ...) + parameters <- list( + pri = pri, + sec = sec, + ter = ter, + ... ) + + 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 @@ -1799,8 +1781,8 @@ get_label <- function(data, var = NULL) { #' #' @examples #' "Lorem ipsum... you know the routine" |> line_break() -#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(fixed = TRUE) -line_break <- function(data, lineLength = 20, fixed = FALSE) { +#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE) +line_break <- function(data, lineLength = 20, force = FALSE) { if (isTRUE(force)) { gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), "\\1\n", data) } else { @@ -1831,7 +1813,7 @@ wrap_plot_list <- function(data, tag_levels = NULL) { .x } })() |> - allign_axes() |> + align_axes() |> patchwork::wrap_plots(guides = "collect", axes = "collect", axis_titles = "collect") if (!is.null(tag_levels)) { out <- out + patchwork::plot_annotation(tag_levels = tag_levels) @@ -1846,19 +1828,21 @@ wrap_plot_list <- function(data, tag_levels = NULL) { } -#' Alligns axes between plots +#' Aligns axes between plots #' #' @param ... ggplot2 objects or list of ggplot2 objects #' #' @returns list of ggplot2 objects #' @export #' -allign_axes <- function(...) { +align_axes <- function(...) { # 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") @@ -1870,7 +1854,7 @@ allign_axes <- function(...) { suppressWarnings({ p |> purrr::map(~ .x + ggplot2::xlim(xr) + ggplot2::ylim(yr)) - }) + }) } #' Extract and clean axis ranges @@ -2213,8 +2197,8 @@ overview_vars <- function(data) { data <- as.data.frame(data) dplyr::tibble( - class = get_classes(data), - type = data_type(data), + icon = data_type(data), + type = icon, name = names(data), n_missing = unname(colSums(is.na(data))), p_complete = 1 - n_missing / nrow(data), @@ -2246,7 +2230,7 @@ create_overview_datagrid <- function(data,...) { std_names <- c( "Name" = "name", - "Class" = "class", + "Icon" = "icon", "Type" = "type", "Missings" = "n_missing", "Complete" = "p_complete", @@ -2284,7 +2268,7 @@ create_overview_datagrid <- function(data,...) { grid <- toastui::grid_columns( grid = grid, - columns = "class", + columns = "icon", header = " ", align = "center",sortable = FALSE, width = 40 @@ -2292,7 +2276,8 @@ create_overview_datagrid <- function(data,...) { grid <- add_class_icon( grid = grid, - column = "class" + column = "icon", + fun = type_icons ) grid <- toastui::grid_format( @@ -2329,32 +2314,14 @@ create_overview_datagrid <- function(data,...) { #' overview_vars() |> #' toastui::datagrid() |> #' add_class_icon() -add_class_icon <- function(grid, column = "class") { +add_class_icon <- function(grid, column = "class", fun=class_icons) { out <- toastui::grid_format( grid = grid, column = column, formatter = function(value) { lapply( X = value, - FUN = function(x) { - if (identical(x, "numeric")) { - shiny::icon("calculator") - } else if (identical(x, "factor")) { - shiny::icon("chart-simple") - } else if (identical(x, "integer")) { - shiny::icon("arrow-down-1-9") - } else if (identical(x, "character")) { - shiny::icon("arrow-down-a-z") - } else if (identical(x, "logical")) { - shiny::icon("toggle-off") - } else if (any(c("Date", "POSIXct", "POSIXt") %in% x)) { - shiny::icon("calendar-days") - } else if ("hms" %in% x) { - shiny::icon("clock") - } else { - shiny::icon("table") - } - } + FUN = fun ) } ) @@ -2368,6 +2335,71 @@ add_class_icon <- function(grid, column = "class") { } +#' Get data class icons +#' +#' @param x character vector of data classes +#' +#' @returns +#' @export +#' +#' @examples +#' "numeric" |> class_icons() +#' default_parsing(mtcars) |> sapply(class) |> class_icons() +class_icons <- function(x) { + if (length(x)>1){ + sapply(x,class_icons) + } else { + if (identical(x, "numeric")) { + shiny::icon("calculator") + } else if (identical(x, "factor")) { + shiny::icon("chart-simple") + } else if (identical(x, "integer")) { + shiny::icon("arrow-down-1-9") + } else if (identical(x, "character")) { + shiny::icon("arrow-down-a-z") + } else if (identical(x, "logical")) { + shiny::icon("toggle-off") + } else if (any(c("Date", "POSIXct", "POSIXt") %in% x)) { + shiny::icon("calendar-days") + } else if ("hms" %in% x) { + shiny::icon("clock") + } else { + shiny::icon("table") + }} +} + +#' Get data type icons +#' +#' @param x character vector of data classes +#' +#' @returns +#' @export +#' +#' @examples +#' "ordinal" |> type_icons() +#' default_parsing(mtcars) |> sapply(data_type) |> type_icons() +type_icons <- function(x) { + if (length(x)>1){ + sapply(x,class_icons) + } else { + if (identical(x, "continuous")) { + shiny::icon("calculator") + } else if (identical(x, "categorical")) { + shiny::icon("chart-simple") + } else if (identical(x, "ordinal")) { + shiny::icon("arrow-down-1-9") + } else if (identical(x, "text")) { + shiny::icon("arrow-down-a-z") + } else if (identical(x, "dichotomous")) { + shiny::icon("toggle-off") + } else if (identical(x,"datetime")) { + shiny::icon("calendar-days") + } else { + shiny::icon("table") + }} +} + + ######## #### Current file: /Users/au301842/FreesearchR/R//helpers.R ######## @@ -2731,7 +2763,7 @@ data_description <- function(data, data_text = "Data") { p_complete <- n_complete / n sprintf( - i18n("%s has %s observations and %s variables, with %s (%s%%) complete cases."), + "%s has %s observations and %s variables, with %s (%s%%) complete cases.", data_text, n, n_var, @@ -3633,13 +3665,13 @@ launch_FreesearchR <- function(...){ #' @name data-plots #' #' @examples -#' mtcars |> plot_box(x = "mpg", y = "cyl", z = "gear") +#' mtcars |> plot_box(pri = "mpg", sec = "cyl", ter = "gear") #' mtcars |> #' default_parsing() |> -#' plot_box(x = "mpg", y = "cyl", z = "gear") -plot_box <- function(data, x, y, z = NULL) { - if (!is.null(z)) { - ds <- split(data, data[z]) +#' plot_box(pri = "mpg", sec = "cyl", ter = "gear") +plot_box <- function(data, pri, sec, ter = NULL) { + if (!is.null(ter)) { + ds <- split(data, data[ter]) } else { ds <- list(data) } @@ -3647,13 +3679,12 @@ plot_box <- function(data, x, y, z = NULL) { out <- lapply(ds, \(.ds){ plot_box_single( data = .ds, - x = x, - y = y + pri = pri, + sec = sec ) }) wrap_plot_list(out) - # patchwork::wrap_plots(out,guides = "collect") } @@ -3668,18 +3699,18 @@ plot_box <- function(data, x, y, z = NULL) { #' #' @examples #' mtcars |> plot_box_single("mpg","cyl") -plot_box_single <- function(data, x, y=NULL, seed = 2103) { +plot_box_single <- function(data, pri, sec=NULL, seed = 2103) { set.seed(seed) - if (is.null(y)) { - y <- "All" - data[[y]] <- y + if (is.null(sec)) { + sec <- "All" + data[[y]] <- sec } - discrete <- !data_type(data[[y]]) %in% "continuous" + discrete <- !data_type(data[[sec]]) %in% "continuous" data |> - ggplot2::ggplot(ggplot2::aes(x = !!dplyr::sym(x), y = !!dplyr::sym(y), fill = !!dplyr::sym(y), group = !!dplyr::sym(y))) + + ggplot2::ggplot(ggplot2::aes(x = !!dplyr::sym(pri), y = !!dplyr::sym(sec), fill = !!dplyr::sym(sec), group = !!dplyr::sym(sec))) + ggplot2::geom_boxplot(linewidth = 1.8, outliers = FALSE) + ## THis could be optional in future ggplot2::geom_jitter(color = "black", size = 2, alpha = 0.9, width = 0.1, height = .5) + @@ -3789,16 +3820,16 @@ ggeulerr <- function( #' D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE) #' ) |> plot_euler("A", c("B", "C"), "D", seed = 4) #' mtcars |> plot_euler("vs", "am", seed = 1) -plot_euler <- function(data, x, y, z = NULL, seed = 2103) { +plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) { set.seed(seed = seed) - if (!is.null(z)) { - ds <- split(data, data[z]) + if (!is.null(ter)) { + ds <- split(data, data[ter]) } else { ds <- list(data) } out <- lapply(ds, \(.x){ - .x[c(x, y)] |> + .x[c(pri, sec)] |> as.data.frame() |> plot_euler_single() }) @@ -3808,7 +3839,6 @@ plot_euler <- function(data, x, y, z = NULL, seed = 2103) { # patchwork::wrap_plots(out, guides = "collect") } -?withCallingHandlers() #' Easily plot single euler diagrams #' #' @returns ggplot2 object @@ -3854,10 +3884,10 @@ plot_euler_single <- function(data) { #' @name data-plots #' #' @examples -#' mtcars |> plot_hbars(x = "carb", y = "cyl") -#' mtcars |> plot_hbars(x = "carb", y = NULL) -plot_hbars <- function(data, x, y, z = NULL) { - out <- vertical_stacked_bars(data = data, score = x, group = y, strata = z) +#' mtcars |> plot_hbars(pri = "carb", sec = "cyl") +#' mtcars |> plot_hbars(pri = "carb", sec = NULL) +plot_hbars <- function(data, pri, sec, ter = NULL) { + out <- vertical_stacked_bars(data = data, score = pri, group = sec, strata = ter) out } @@ -3998,42 +4028,42 @@ plot_ridge <- function(data, x, y, z = NULL, ...) { #' last = sample(c(TRUE, FALSE, FALSE), 100, TRUE) #' ) |> #' sankey_ready("first", "last") -sankey_ready <- function(data, x, y, numbers = "count", ...) { +sankey_ready <- function(data, pri, sec, numbers = "count", ...) { ## TODO: Ensure ordering x and y ## Ensure all are factors - data[c(x, y)] <- data[c(x, y)] |> + data[c(pri, sec)] <- data[c(pri, sec)] |> dplyr::mutate(dplyr::across(!dplyr::where(is.factor), forcats::as_factor)) - out <- dplyr::count(data, !!dplyr::sym(x), !!dplyr::sym(y)) + out <- dplyr::count(data, !!dplyr::sym(pri), !!dplyr::sym(sec)) out <- out |> - dplyr::group_by(!!dplyr::sym(x)) |> + dplyr::group_by(!!dplyr::sym(pri)) |> dplyr::mutate(gx.sum = sum(n)) |> dplyr::ungroup() |> - dplyr::group_by(!!dplyr::sym(y)) |> + dplyr::group_by(!!dplyr::sym(sec)) |> 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, ")")) + lx = factor(paste0(!!dplyr::sym(pri), "\n(n=", gx.sum, ")")), + ly = factor(paste0(!!dplyr::sym(sec), "\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), "%)")) + lx = factor(paste0(!!dplyr::sym(pri), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)")), + ly = factor(paste0(!!dplyr::sym(sec), "\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")) + if (is.factor(data[[pri]])) { + index <- match(levels(data[[pri]]), 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")) + if (is.factor(data[[sec]])) { + index <- match(levels(data[[sec]]), str_remove_last(levels(out$ly), "\n")) out$ly <- factor(out$ly, levels = levels(out$ly)[index]) } @@ -4058,15 +4088,15 @@ str_remove_last <- function(data, pattern = "\n") { #' 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]) +plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "x", colors = NULL) { + if (!is.null(ter)) { + ds <- split(data, data[ter]) } else { ds <- list(data) } out <- lapply(ds, \(.ds){ - plot_sankey_single(.ds, x = x, y = y, color.group = color.group, colors = colors) + plot_sankey_single(.ds, x = pri, y = sec, color.group = color.group, colors = colors) }) patchwork::wrap_plots(out) @@ -4095,10 +4125,10 @@ default_theme <- function() { #' first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), #' last = sample(c(TRUE, FALSE, FALSE), 100, TRUE) #' ) |> -#' plot_sankey_single("first", "last", color.group = "x") -plot_sankey_single <- function(data, x, y, color.group = c("x", "y"), colors = NULL, ...) { +#' plot_sankey_single("first", "last", color.group = "pri") +plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), colors = NULL, ...) { color.group <- match.arg(color.group) - data <- data |> sankey_ready(x = x, y = y, ...) + data <- data |> sankey_ready(pri = pri, sec = sec, ...) library(ggalluvial) @@ -4106,13 +4136,13 @@ plot_sankey_single <- function(data, x, y, color.group = c("x", "y"), colors = N 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]]))) + if (color.group == "sec") { + main.colors <- viridisLite::viridis(n = length(levels(data[[sec]]))) + secondary.colors <- rep(na.color, length(levels(data[[pri]]))) 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]]))) + main.colors <- viridisLite::viridis(n = length(levels(data[[pri]]))) + secondary.colors <- rep(na.color, length(levels(data[[sec]]))) label.colors <- Reduce(c, lapply(list(rev(main.colors), secondary.colors), contrast_text)) } colors <- c(na.color, main.colors, secondary.colors) @@ -4120,33 +4150,33 @@ plot_sankey_single <- function(data, x, y, color.group = c("x", "y"), colors = N label.colors <- contrast_text(colors) } - group_labels <- c(get_label(data, x), get_label(data, y)) |> + group_labels <- c(get_label(data, pri), get_label(data, sec)) |> sapply(line_break) |> unname() p <- ggplot2::ggplot(data, ggplot2::aes(y = n, axis1 = lx, axis2 = ly)) - if (color.group == "y") { + if (color.group == "sec") { p <- p + ggalluvial::geom_alluvium( - ggplot2::aes(fill = !!dplyr::sym(y), color = !!dplyr::sym(y)), + ggplot2::aes(fill = !!dplyr::sym(sec), color = !!dplyr::sym(sec)), width = 1 / 16, alpha = .8, knot.pos = 0.4, curve_type = "sigmoid" - ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(y)), + ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(sec)), size = 2, width = 1 / 3.4 ) } else { p <- p + ggalluvial::geom_alluvium( - ggplot2::aes(fill = !!dplyr::sym(x), color = !!dplyr::sym(x)), + ggplot2::aes(fill = !!dplyr::sym(pri), color = !!dplyr::sym(pri)), width = 1 / 16, alpha = .8, knot.pos = 0.4, curve_type = "sigmoid" - ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(x)), + ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(pri)), size = 2, width = 1 / 3.4 ) @@ -4195,20 +4225,24 @@ plot_sankey_single <- function(data, x, y, color.group = c("x", "y"), colors = N #' @name data-plots #' #' @examples -#' mtcars |> plot_scatter(x = "mpg", y = "wt") -plot_scatter <- function(data, x, y, z = NULL) { - if (is.null(z)) { +#' mtcars |> plot_scatter(pri = "mpg", sec = "wt") +plot_scatter <- function(data, pri, sec, ter = NULL) { + if (is.null(ter)) { rempsyc::nice_scatter( data = data, - predictor = y, - response = x, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x) + predictor = sec, + response = pri, + xtitle = get_label(data, var = sec), + ytitle = get_label(data, var = pri) ) } else { rempsyc::nice_scatter( data = data, - predictor = y, - response = x, - group = z, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x) + predictor = sec, + response = pri, + group = ter, + xtitle = get_label(data, var = sec), + ytitle = get_label(data, var = pri) ) } } @@ -4226,10 +4260,10 @@ plot_scatter <- function(data, x, y, z = NULL) { #' @name data-plots #' #' @examples -#' mtcars |> plot_violin(x = "mpg", y = "cyl", z = "gear") -plot_violin <- function(data, x, y, z = NULL) { - if (!is.null(z)) { - ds <- split(data, data[z]) +#' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear") +plot_violin <- function(data, pri, sec, ter = NULL) { + if (!is.null(ter)) { + ds <- split(data, data[ter]) } else { ds <- list(data) } @@ -4237,8 +4271,10 @@ plot_violin <- function(data, x, y, z = NULL) { out <- lapply(ds, \(.ds){ rempsyc::nice_violin( data = .ds, - group = y, - response = x, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x) + group = sec, + response = pri, + xtitle = get_label(data, var = sec), + ytitle = get_label(data, var = pri) ) }) diff --git a/man/data-plots.Rd b/man/data-plots.Rd index f580b0e0..171c45f9 100644 --- a/man/data-plots.Rd +++ b/man/data-plots.Rd @@ -20,23 +20,23 @@ data_visuals_ui(id, tab_title = "Plots", ...) data_visuals_server(id, data, ...) -create_plot(data, type, x, y, z = NULL, ...) +create_plot(data, type, pri, sec, ter = NULL, ...) -plot_box(data, x, y, z = NULL) +plot_box(data, pri, sec, ter = NULL) -plot_box_single(data, x, y = NULL, seed = 2103) +plot_box_single(data, pri, sec = NULL, seed = 2103) -plot_hbars(data, x, y, z = NULL) +plot_hbars(data, pri, sec, ter = NULL) plot_ridge(data, x, y, z = NULL, ...) -sankey_ready(data, x, y, numbers = "count", ...) +sankey_ready(data, pri, sec, numbers = "count", ...) -plot_sankey(data, x, y, z = NULL, color.group = "x", colors = NULL) +plot_sankey(data, pri, sec, ter = NULL, color.group = "x", colors = NULL) -plot_scatter(data, x, y, z = NULL) +plot_scatter(data, pri, sec, ter = NULL) -plot_violin(data, x, y, z = NULL) +plot_violin(data, pri, sec, ter = NULL) } \arguments{ \item{id}{Module id. (Use 'ns("id")')} @@ -47,11 +47,11 @@ plot_violin(data, x, y, z = NULL) \item{type}{plot type (derived from possible_plots() and matches custom function)} -\item{x}{primary variable} +\item{pri}{primary variable} -\item{y}{secondary variable} +\item{sec}{secondary variable} -\item{z}{tertiary variable} +\item{ter}{tertiary variable} } \value{ Shiny ui module @@ -98,14 +98,14 @@ Beautiful violin plot Beatiful violin plot } \examples{ -create_plot(mtcars, "plot_violin", "mpg", "cyl") -mtcars |> plot_box(x = "mpg", y = "cyl", z = "gear") +create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() +mtcars |> plot_box(pri = "mpg", sec = "cyl", ter = "gear") mtcars |> default_parsing() |> - plot_box(x = "mpg", y = "cyl", z = "gear") + plot_box(pri = "mpg", sec = "cyl", ter = "gear") mtcars |> plot_box_single("mpg","cyl") -mtcars |> plot_hbars(x = "carb", y = "cyl") -mtcars |> plot_hbars(x = "carb", y = NULL) +mtcars |> plot_hbars(pri = "carb", sec = "cyl") +mtcars |> plot_hbars(pri = "carb", sec = NULL) mtcars |> default_parsing() |> plot_ridge(x = "mpg", y = "cyl") @@ -123,6 +123,6 @@ ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_fac ds |> plot_sankey("first", "last") ds |> plot_sankey("first", "last", color.group = "y") ds |> plot_sankey("first", "last", z = "g", color.group = "y") -mtcars |> plot_scatter(x = "mpg", y = "wt") -mtcars |> plot_violin(x = "mpg", y = "cyl", z = "gear") +mtcars |> plot_scatter(pri = "mpg", sec = "wt") +mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear") } diff --git a/man/plot_euler.Rd b/man/plot_euler.Rd index 78f3333d..2785047a 100644 --- a/man/plot_euler.Rd +++ b/man/plot_euler.Rd @@ -4,18 +4,18 @@ \alias{plot_euler} \title{Easily plot euler diagrams} \usage{ -plot_euler(data, x, y, z = NULL, seed = 2103) +plot_euler(data, pri, sec, ter = NULL, seed = 2103) } \arguments{ \item{data}{data} +\item{seed}{seed} + \item{x}{name of main variable} \item{y}{name of secondary variables} \item{z}{grouping variable} - -\item{seed}{seed} } \value{ patchwork object diff --git a/man/plot_sankey_single.Rd b/man/plot_sankey_single.Rd index b1410f76..0c48fde1 100644 --- a/man/plot_sankey_single.Rd +++ b/man/plot_sankey_single.Rd @@ -4,7 +4,14 @@ \alias{plot_sankey_single} \title{Beautiful sankey plot} \usage{ -plot_sankey_single(data, x, y, color.group = c("x", "y"), colors = NULL, ...) +plot_sankey_single( + data, + pri, + sec, + color.group = c("pri", "sec"), + colors = NULL, + ... +) } \arguments{ \item{color.group}{set group to colour by. "x" or "y".} @@ -29,5 +36,5 @@ data.frame( first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), last = sample(c(TRUE, FALSE, FALSE), 100, TRUE) ) |> - plot_sankey_single("first", "last", color.group = "x") + plot_sankey_single("first", "last", color.group = "pri") } diff --git a/tests/testthat.R b/tests/testthat.R index 7fd7562c..940fd4ec 100644 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -8,5 +8,6 @@ library(testthat) library(FreesearchR) +library(shiny) test_check("FreesearchR") diff --git a/tests/testthat/_snaps/baseline_table.md b/tests/testthat/_snaps/baseline_table.md deleted file mode 100644 index f5cc8423..00000000 --- a/tests/testthat/_snaps/baseline_table.md +++ /dev/null @@ -1,2182 +0,0 @@ -# Creates correct table - - Code - create_baseline(mtcars, by.var = "gear", add.p = "yes" == "yes", add.overall = TRUE, - theme = "lancet") - Message - Setting theme "The Lancet" - Output -
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CharacteristicOverall
- N = 321		3
- N = 151		4
- N = 121		5
- N = 51		p-value2
mpg19·2 (15·4 – 22·8)15·5 (14·3 – 18·7)22·8 (21·0 – 28·9)19·7 (15·8 – 26·0)0·0008
cyl



<0·0001
    411 (34%)1 (6·7%)8 (67%)2 (40%)
    67 (22%)2 (13%)4 (33%)1 (20%)
    814 (44%)12 (80%)0 (0%)2 (40%)
disp196 (121 – 334)318 (276 – 400)131 (79 – 160)145 (120 – 301)0·0003
hp123 (96 – 180)180 (150 – 215)94 (66 – 110)175 (113 – 264)0·0007
drat3·70 (3·08 – 3·92)3·08 (3·00 – 3·21)3·92 (3·90 – 4·10)3·77 (3·62 – 4·22)<0·0001
wt3·33 (2·54 – 3·65)3·73 (3·44 – 4·07)2·70 (2·07 – 3·17)2·77 (2·14 – 3·17)0·0003
qsec17·71 (16·89 – 18·90)17·42 (17·02 – 18·00)18·76 (18·41 – 19·69)15·50 (14·60 – 16·70)0·0017
vs14 (44%)3 (20%)10 (83%)1 (20%)0·0013
am13 (41%)0 (0%)8 (67%)5 (100%)<0·0001
carb



0·24
    17 (22%)3 (20%)4 (33%)0 (0%)
    210 (31%)4 (27%)4 (33%)2 (40%)
    33 (9·4%)3 (20%)0 (0%)0 (0%)
    410 (31%)5 (33%)4 (33%)1 (20%)
    61 (3·1%)0 (0%)0 (0%)1 (20%)
    81 (3·1%)0 (0%)0 (0%)1 (20%)
1 Median (IQR); n (%)
2 Kruskal-Wallis rank sum test; Fisher’s exact test
-
- ---- - - Code - create_baseline(mtcars, by.var = "none", add.p = FALSE, add.overall = FALSE, - theme = "lancet") - Message - Setting theme "The Lancet" - Output -
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CharacteristicN = 321
mpg19·2 (15·4 – 22·8)
cyl
    411 (34%)
    67 (22%)
    814 (44%)
disp196 (121 – 334)
hp123 (96 – 180)
drat3·70 (3·08 – 3·92)
wt3·33 (2·54 – 3·65)
qsec17·71 (16·89 – 18·90)
vs14 (44%)
am13 (41%)
gear
    315 (47%)
    412 (38%)
    55 (16%)
carb
    17 (22%)
    210 (31%)
    33 (9·4%)
    410 (31%)
    61 (3·1%)
    81 (3·1%)
1 Median (IQR); n (%)
-
- ---- - - Code - create_baseline(mtcars, by.var = "test", add.p = FALSE, add.overall = FALSE, - theme = "jama") - Message - Setting theme "JAMA" - Output -
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CharacteristicN = 32
mpg, Median (IQR)19.2 (15.4 – 22.8)
cyl, n (%)
    411 (34)
    67 (22)
    814 (44)
disp, Median (IQR)196 (121 – 334)
hp, Median (IQR)123 (96 – 180)
drat, Median (IQR)3.70 (3.08 – 3.92)
wt, Median (IQR)3.33 (2.54 – 3.65)
qsec, Median (IQR)17.71 (16.89 – 18.90)
vs, n (%)14 (44)
am, n (%)13 (41)
gear, n (%)
    315 (47)
    412 (38)
    55 (16)
carb, n (%)
    17 (22)
    210 (31)
    33 (9.4)
    410 (31)
    61 (3.1)
    81 (3.1)
-
- ---- - - Code - create_baseline(default_parsing(mtcars), by.var = "am", add.p = FALSE, - add.overall = FALSE, theme = "nejm") - Message - Setting theme "New England Journal of Medicine" - Output -
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CharacteristicFALSE
- N = 191		TRUE
- N = 131
mpg17.3 (14.7 – 19.2)22.8 (21.0 – 30.4)
cyl

    43 (16)8 (62)
    64 (21)3 (23)
    812 (63)2 (15)
disp276 (168 – 360)120 (79 – 160)
hp175 (110 – 205)109 (66 – 113)
drat3.15 (3.07 – 3.70)4.08 (3.85 – 4.22)
wt3.52 (3.44 – 3.85)2.32 (1.94 – 2.78)
qsec17.82 (17.05 – 19.44)17.02 (16.46 – 18.61)
vs7 (37)7 (54)
gear

    315 (79)0 (0)
    44 (21)8 (62)
    50 (0)5 (38)
carb

    13 (16)4 (31)
    26 (32)4 (31)
    33 (16)0 (0)
    47 (37)3 (23)
    60 (0)1 (7.7)
    80 (0)1 (7.7)
1 Median (IQR); n (%)
-
- diff --git a/tests/testthat/test-baseline_table.R b/tests/testthat/test-baseline_table.R index 089104c3..e36ebd17 100644 --- a/tests/testthat/test-baseline_table.R +++ b/tests/testthat/test-baseline_table.R @@ -3,44 +3,26 @@ test_that("Creates correct table",{ ## This is by far the easiest way to test all functions. Based on examples. - expect_snapshot(create_baseline(mtcars,by.var = "gear", add.p = "yes" == "yes",add.overall = TRUE, theme = "lancet")) - expect_snapshot(create_baseline(mtcars,by.var = "none", add.p = FALSE,add.overall = FALSE, theme = "lancet")) - expect_snapshot(create_baseline(mtcars,by.var = "test", add.p = FALSE,add.overall = FALSE, theme = "jama")) - expect_snapshot(create_baseline(default_parsing(mtcars),by.var = "am", add.p = FALSE,add.overall = FALSE, theme = "nejm")) -}) + tbl <- create_baseline(mtcars,by.var = "gear", add.p = "yes" == "yes",add.overall = TRUE, theme = "lancet") -test_that("Creates table", { - tbl <- mtcars |> baseline_table(fun.args = list(by = "gear")) - - expect_equal(length(tbl), 5) - - expect_equal(NROW(tbl$table_body), 19) - - expect_equal(NCOL(tbl$table_body), 8) - - expect_equal(names(tbl), c("table_body", "table_styling", "call_list", "cards", "inputs")) -}) - -test_that("Creates table", { - tbl <- mtcars |> create_baseline(by.var = "gear", add.p = "yes" == "yes") - - expect_equal(length(tbl), 5) + expect_equal(length(tbl),5) expect_equal(NROW(tbl$table_body), 19) expect_equal(NCOL(tbl$table_body), 13) - + tbl$call_list expect_equal(names(tbl), c("table_body", "table_styling", "call_list", "cards", "inputs")) + + tbl <- create_baseline(mtcars,by.var = "none", add.p = FALSE,add.overall = FALSE, theme = "lancet") + + expect_equal(length(tbl),5) + + tbl <- create_baseline(mtcars,by.var = "test", add.p = FALSE,add.overall = FALSE, theme = "jama") + + expect_equal(length(tbl),5) + + tbl <- create_baseline(default_parsing(mtcars),by.var = "am", add.p = FALSE,add.overall = FALSE, theme = "nejm") + + expect_equal(length(tbl),5) }) -test_that("Creates table", { - tbl <- mtcars |> create_baseline(by.var = "gear", add.p = "yes" == "yes") - - expect_equal(length(tbl), 5) - - expect_equal(NROW(tbl$table_body), 19) - - expect_equal(NCOL(tbl$table_body), 13) - - expect_equal(names(tbl), c("table_body", "table_styling", "call_list", "cards", "inputs")) -}) diff --git a/tests/testthat/test-cut-variable-dates.R b/tests/testthat/test-cut-variable-dates.R new file mode 100644 index 00000000..694a6688 --- /dev/null +++ b/tests/testthat/test-cut-variable-dates.R @@ -0,0 +1,47 @@ +test_that("datetime cutting works", { + ## HMS + data <- readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20")) + + breaks <- list(2, "min", "hour", hms::as_hms(c("01:00:00", "03:01:20", "9:20:20"))) + + lapply(breaks, \(.x){ + cut_var(x = data, breaks = .x) + }) |> expect_snapshot() + + + data <- readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "03:02:20", NA)) + + lapply(breaks, \(.x){ + cut_var(x = data, breaks = .x) + }) |> expect_snapshot() + + expect_snapshot( + readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "03:02:20", NA)) |> cut_var(breaks = lubridate::as_datetime(c(hms::as_hms(levels(cut_var(data, 2))), hms::as_hms(max(data, na.rm = TRUE) + 1))), right = FALSE) + ) + + ## DATETIME + + data <- readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) + + breaks <- list(list(breaks = 2), list(breaks = "weekday"), list(breaks = "month_only"), list(breaks = NULL, format = "%A-%H")) + + lapply(breaks, \(.x){ + do.call(cut_var, modifyList(.x, list(x = data))) + }) |> expect_snapshot() +}) + +## is_any_class +test_that("is_any_class works", { + expect_snapshot( + vapply(REDCapCAST::redcapcast_data, \(.x){ + is_any_class(.x, c("hms", "Date", "POSIXct", "POSIXt")) + }, logical(1)) + ) + + expect_snapshot( + vapply(REDCapCAST::redcapcast_data, is_datetime, logical(1)) + + ) + +}) + diff --git a/tests/testthat/test-data_plots.R b/tests/testthat/test-data_plots.R index 247a8eef..a173d378 100644 --- a/tests/testthat/test-data_plots.R +++ b/tests/testthat/test-data_plots.R @@ -41,7 +41,6 @@ test_that("get_plot_options works", { ## create_plot and friends test_that("create_plot works", { - ## Violin p_list <- create_plot(mtcars, type = "plot_violin", pri = "mpg", sec = "cyl", ter = "am") p <- p_list[[1]] + ggplot2::labs(title = "Test plot") @@ -81,6 +80,6 @@ test_that("get_label works", { ## line_break test_that("line_break works", { expect_snapshot("Lorem ipsum... you know the routine" |> line_break()) - expect_snapshot(paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE, lineLength = 5)) - expect_snapshot(paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = FALSE)) + expect_snapshot(paste(rep(letters, 5), collapse = "") |> line_break(force = TRUE, lineLength = 5)) + expect_snapshot(paste(rep(letters, 5), collapse = "") |> line_break(force = FALSE)) }) From fb6f1a708d08240e089f813863c7bbf57254eb84 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Tue, 15 Apr 2025 16:27:43 +0200 Subject: [PATCH 3/4] bug corrected --- R/app_version.R | 2 +- R/correlations-module.R | 2 +- inst/apps/FreesearchR/app.R | 9 ++++++--- .../rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf | 2 +- 4 files changed, 9 insertions(+), 6 deletions(-) diff --git a/R/app_version.R b/R/app_version.R index c47f954b..e562fc16 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'Version: 25.4.3.250415_1539' +app_version <- function()'Version: 25.4.3.250415_1627' diff --git a/R/correlations-module.R b/R/correlations-module.R index 4d56be19..8330f2ce 100644 --- a/R/correlations-module.R +++ b/R/correlations-module.R @@ -47,7 +47,7 @@ data_correlations_server <- function(id, out <- data() } # out |> dplyr::mutate(dplyr::across(tidyselect::everything(),as.numeric)) - sapply(data,as.numeric) + sapply(out,as.numeric) # as.numeric() }) diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index 9c0184b9..79bc3f7b 100644 --- a/inst/apps/FreesearchR/app.R +++ b/inst/apps/FreesearchR/app.R @@ -10,7 +10,7 @@ #### Current file: /Users/au301842/FreesearchR/R//app_version.R ######## -app_version <- function()'Version: 25.4.3.250415_1539' +app_version <- function()'Version: 25.4.3.250415_1627' ######## @@ -208,7 +208,7 @@ data_correlations_server <- function(id, out <- data() } # out |> dplyr::mutate(dplyr::across(tidyselect::everything(),as.numeric)) - sapply(data,as.numeric) + sapply(out,as.numeric) # as.numeric() }) @@ -2394,9 +2394,12 @@ type_icons <- function(x) { shiny::icon("toggle-off") } else if (identical(x,"datetime")) { shiny::icon("calendar-days") + } else if (identical(x,"id")) { + shiny::icon("id-card") } else { shiny::icon("table") - }} + } + } } diff --git a/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf b/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf index 793c917f..8d0b3996 100644 --- a/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf +++ b/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf @@ -5,6 +5,6 @@ account: agdamsbo server: shinyapps.io hostUrl: https://api.shinyapps.io/v1 appId: 13611288 -bundleId: 10111887 +bundleId: url: https://agdamsbo.shinyapps.io/freesearcheR/ version: 1 From 2065c9c8005792cd472dc0095406805bf3473993 Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Tue, 15 Apr 2025 16:56:08 +0200 Subject: [PATCH 4/4] new docs --- NAMESPACE | 3 ++- R/data-summary.R | 12 +++++------ .../shinyapps.io/agdamsbo/freesearcheR.dcf | 2 +- man/add_class_icon.Rd | 2 +- man/class_icons.Rd | 21 +++++++++++++++++++ man/cut-variable.Rd | 12 ----------- man/type_icons.Rd | 21 +++++++++++++++++++ 7 files changed, 52 insertions(+), 21 deletions(-) create mode 100644 man/class_icons.Rd create mode 100644 man/type_icons.Rd diff --git a/NAMESPACE b/NAMESPACE index e8ca6f0a..26d42927 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -11,6 +11,7 @@ export(append_column) export(append_list) export(argsstring2list) export(baseline_table) +export(class_icons) export(clean_common_axis) export(clean_date) export(clean_sep) @@ -107,6 +108,7 @@ export(supported_functions) export(supported_plots) export(symmetrical_scale_x_log10) export(tbl_merge) +export(type_icons) export(update_factor_server) export(update_factor_ui) export(update_variables_server) @@ -114,7 +116,6 @@ export(update_variables_ui) export(vectorSelectInput) export(vertical_stacked_bars) export(wide2long) -export(winbox_cut_variable) export(winbox_update_factor) export(wrap_plot_list) export(write_quarto) diff --git a/R/data-summary.R b/R/data-summary.R index f3f3bfbb..e70eb507 100644 --- a/R/data-summary.R +++ b/R/data-summary.R @@ -297,15 +297,15 @@ add_class_icon <- function(grid, column = "class", fun=class_icons) { #' #' @param x character vector of data classes #' -#' @returns +#' @returns list #' @export #' #' @examples -#' "numeric" |> class_icons() -#' default_parsing(mtcars) |> sapply(class) |> class_icons() +#' "numeric" |> class_icons()|> str() +#' mtcars |> sapply(class) |> class_icons() |> str() class_icons <- function(x) { if (length(x)>1){ - sapply(x,class_icons) + lapply(x,class_icons) } else { if (identical(x, "numeric")) { shiny::icon("calculator") @@ -330,7 +330,7 @@ class_icons <- function(x) { #' #' @param x character vector of data classes #' -#' @returns +#' @returns list #' @export #' #' @examples @@ -338,7 +338,7 @@ class_icons <- function(x) { #' default_parsing(mtcars) |> sapply(data_type) |> type_icons() type_icons <- function(x) { if (length(x)>1){ - sapply(x,class_icons) + lapply(x,class_icons) } else { if (identical(x, "continuous")) { shiny::icon("calculator") diff --git a/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf b/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf index 8d0b3996..464b7ee6 100644 --- a/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf +++ b/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf @@ -5,6 +5,6 @@ account: agdamsbo server: shinyapps.io hostUrl: https://api.shinyapps.io/v1 appId: 13611288 -bundleId: +bundleId: 10119038 url: https://agdamsbo.shinyapps.io/freesearcheR/ version: 1 diff --git a/man/add_class_icon.Rd b/man/add_class_icon.Rd index e21aeb3c..a35b6211 100644 --- a/man/add_class_icon.Rd +++ b/man/add_class_icon.Rd @@ -4,7 +4,7 @@ \alias{add_class_icon} \title{Convert class grid column to icon} \usage{ -add_class_icon(grid, column = "class") +add_class_icon(grid, column = "class", fun = class_icons) } \arguments{ \item{grid}{grid} diff --git a/man/class_icons.Rd b/man/class_icons.Rd new file mode 100644 index 00000000..a21c3e62 --- /dev/null +++ b/man/class_icons.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data-summary.R +\name{class_icons} +\alias{class_icons} +\title{Get data class icons} +\usage{ +class_icons(x) +} +\arguments{ +\item{x}{character vector of data classes} +} +\value{ +list +} +\description{ +Get data class icons +} +\examples{ +"numeric" |> class_icons()|> str() +mtcars |> sapply(class) |> class_icons() |> str() +} diff --git a/man/cut-variable.Rd b/man/cut-variable.Rd index 1c034b1a..6403fa7f 100644 --- a/man/cut-variable.Rd +++ b/man/cut-variable.Rd @@ -5,7 +5,6 @@ \alias{cut_variable_ui} \alias{cut_variable_server} \alias{modal_cut_variable} -\alias{winbox_cut_variable} \title{Module to Convert Numeric to Factor} \usage{ cut_variable_ui(id) @@ -19,13 +18,6 @@ modal_cut_variable( size = "l", footer = NULL ) - -winbox_cut_variable( - id, - title = i18n("Convert Numeric to Factor"), - options = shinyWidgets::wbOptions(), - controls = shinyWidgets::wbControls() -) } \arguments{ \item{id}{Module ID.} @@ -47,10 +39,6 @@ pass \code{\link[bslib:bs_theme]{bslib::bs_theme()}} to the \code{theme} argumen like \code{\link[shiny:fluidPage]{fluidPage()}}).} \item{footer}{UI for footer. Use \code{NULL} for no footer.} - -\item{options}{List of options, see \code{\link[shinyWidgets:wbOptions]{wbOptions()}}.} - -\item{controls}{List of controls, see \code{\link[shinyWidgets:wbControls]{wbControls()}}.} } \value{ A \code{\link[shiny:reactive]{shiny::reactive()}} function returning the data. diff --git a/man/type_icons.Rd b/man/type_icons.Rd new file mode 100644 index 00000000..54c46b2d --- /dev/null +++ b/man/type_icons.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data-summary.R +\name{type_icons} +\alias{type_icons} +\title{Get data type icons} +\usage{ +type_icons(x) +} +\arguments{ +\item{x}{character vector of data classes} +} +\value{ +list +} +\description{ +Get data type icons +} +\examples{ +"ordinal" |> type_icons() +default_parsing(mtcars) |> sapply(data_type) |> type_icons() +}