diff --git a/DESCRIPTION b/DESCRIPTION index 39f91d74..a951fca0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -80,7 +80,9 @@ Suggests: rsconnect, knitr, rmarkdown, - testthat (>= 3.0.0) + testthat (>= 3.0.0), + 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/NAMESPACE b/NAMESPACE index d1f911b5..26d42927 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -5,12 +5,13 @@ 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) export(baseline_table) +export(class_icons) export(clean_common_axis) export(clean_date) export(clean_sep) @@ -95,7 +96,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) @@ -108,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) @@ -115,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/app_version.R b/R/app_version.R index 09283d38..e562fc16 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_1627' 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/correlations-module.R b/R/correlations-module.R index adfd0ae9..8330f2ce 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(out,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/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..e70eb507 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 list +#' @export +#' +#' @examples +#' "numeric" |> class_icons()|> str() +#' mtcars |> sapply(class) |> class_icons() |> str() +class_icons <- function(x) { + if (length(x)>1){ + lapply(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 list +#' @export +#' +#' @examples +#' "ordinal" |> type_icons() +#' default_parsing(mtcars) |> sapply(data_type) |> type_icons() +type_icons <- function(x) { + if (length(x)>1){ + lapply(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/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/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/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/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index 85aef6bc..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.250414_1342' +app_version <- function()'Version: 25.4.3.250415_1627' ######## @@ -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(out,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,74 @@ 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 if (identical(x,"id")) { + shiny::icon("id-card") + } else { + shiny::icon("table") + } + } +} + + ######## #### Current file: /Users/au301842/FreesearchR/R//helpers.R ######## @@ -2731,7 +2766,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 +3668,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 +3682,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 +3702,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 +3823,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 +3842,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 +3887,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 +4031,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 +4091,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 +4128,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 +4139,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 +4153,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 +4228,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 +4263,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 +4274,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/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf b/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf index 793c917f..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: 10111887 +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/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/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/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/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/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/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/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/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/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() +} 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/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-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-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-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 new file mode 100644 index 00000000..a173d378 --- /dev/null +++ b/tests/testthat/test-data_plots.R @@ -0,0 +1,85 @@ +## 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(rep(letters, 5), collapse = "") |> line_break(force = TRUE, lineLength = 5)) + expect_snapshot(paste(rep(letters, 5), collapse = "") |> line_break(force = FALSE)) +})