diff --git a/DESCRIPTION b/DESCRIPTION index 39f91d7..9efc067 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 d1f911b..e8ca6f0 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 adfd0ae..4d56be1 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 a0ab2f0..783a8d4 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 09ab6c8..45b4886 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 88ce437..36c8f91 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 4f322fa..84ead0d 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 baddb7f..55a0b4e 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 8f38671..c2389b0 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 7feabd7..e6c5434 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 5bb4a39..01a43a3 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 48639a0..70be11c 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 1178917..4c13ff3 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 4dab22b..b6c03c0 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 65e2439..8271912 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 d66412b..1ad79ca 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 c74ead0..65c987c 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 39f3cc4..6815568 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 41bb4ee..0000000 --- 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 7363319..716a982 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 7b3f366..c1a7ef9 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 0000000..f5cc842 --- /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 0000000..258000c --- /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 0000000..6a69f86 --- /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 0000000..312df32 --- /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 0000000..30478c1 --- /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 044a8ba..6c8bb33 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 0000000..247a8ee --- /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)) +})