diff --git a/DESCRIPTION b/DESCRIPTION index a951fca0..39f91d74 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -80,9 +80,7 @@ Suggests: rsconnect, knitr, rmarkdown, - testthat (>= 3.0.0), - shinytest, - covr + testthat (>= 3.0.0) 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 26d42927..d1f911b5 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -5,13 +5,12 @@ 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) @@ -96,6 +95,7 @@ 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,7 +108,6 @@ 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) @@ -116,6 +115,7 @@ 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 e562fc16..09283d38 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'Version: 25.4.3.250415_1627' +app_version <- function()'Version: 25.4.3.250414_1342' diff --git a/R/baseline_table.R b/R/baseline_table.R index ecab00b8..4eaccde4 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 } } - suppressMessages(gtsummary::theme_gtsummary_journal(journal = theme)) + gtsummary::theme_gtsummary_journal(journal = theme) args <- list(...) diff --git a/R/correlations-module.R b/R/correlations-module.R index 8330f2ce..adfd0ae9 100644 --- a/R/correlations-module.R +++ b/R/correlations-module.R @@ -46,8 +46,7 @@ data_correlations_server <- function(id, } else { out <- data() } - # out |> dplyr::mutate(dplyr::across(tidyselect::everything(),as.numeric)) - sapply(out,as.numeric) + out |> dplyr::mutate(dplyr::across(tidyselect::everything(),as.numeric)) # as.numeric() }) @@ -101,9 +100,8 @@ data_correlations_server <- function(id, } correlation_pairs <- function(data, threshold = .8) { - 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)) + data <- data[!sapply(data, is.character)] + 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 e18f6150..240d7551 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(x, ...) + base::cut.default(x, ...) } #' @name cut_var @@ -581,6 +581,36 @@ 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]] @@ -597,4 +627,3 @@ 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 e70eb507..b3aff31d 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( - icon = data_type(data), - type = icon, + class = get_classes(data), + type = data_type(data), 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", - "Icon" = "icon", + "Class" = "class", "Type" = "type", "Missings" = "n_missing", "Complete" = "p_complete", @@ -226,7 +226,7 @@ create_overview_datagrid <- function(data,...) { grid <- toastui::grid_columns( grid = grid, - columns = "icon", + columns = "class", header = " ", align = "center",sortable = FALSE, width = 40 @@ -234,8 +234,7 @@ create_overview_datagrid <- function(data,...) { grid <- add_class_icon( grid = grid, - column = "icon", - fun = type_icons + column = "class" ) grid <- toastui::grid_format( @@ -272,14 +271,32 @@ create_overview_datagrid <- function(data,...) { #' overview_vars() |> #' toastui::datagrid() |> #' add_class_icon() -add_class_icon <- function(grid, column = "class", fun=class_icons) { +add_class_icon <- function(grid, column = "class") { out <- toastui::grid_format( grid = grid, column = column, formatter = function(value) { lapply( X = value, - FUN = fun + 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") + } + } ) } ) @@ -291,71 +308,3 @@ add_class_icon <- function(grid, column = "class", fun=class_icons) { 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 783a8d4c..a0ab2f00 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,30 +318,37 @@ data_visuals_server <- function(id, shiny::observeEvent(input$act_plot, { - if (NROW(data()) > 0) { - tryCatch( - { - parameters <- list( - type = rv$plot.params()[["fun"]], - pri = input$primary, - sec = input$secondary, - ter = input$tertiary - ) + if (NROW(data())>0){ + tryCatch( + { + parameters <- list( + 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")) - }) + 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 + # ) + }) - 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 ) @@ -408,7 +415,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] @@ -443,21 +450,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", @@ -471,30 +478,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( @@ -505,7 +512,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 ) ) @@ -584,9 +591,9 @@ get_plot_options <- function(data) { #' Wrapper to create plot based on provided type #' #' @param data data.frame -#' @param pri primary variable -#' @param sec secondary variable -#' @param ter tertiary variable +#' @param x primary variable +#' @param y secondary variable +#' @param z tertiary variable #' @param type plot type (derived from possible_plots() and matches custom function) #' @param ... ignored for now #' @@ -596,36 +603,20 @@ get_plot_options <- function(data) { #' @export #' #' @examples -#' 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 - } +#' create_plot(mtcars, "plot_violin", "mpg", "cyl") +create_plot <- function(data, type, x, y, z = NULL, ...) { + if (!any(y %in% names(data))) { + y <- NULL } - if (!is.null(ter)) { - if (!ter %in% names(data)) { - ter <- NULL - } + if (!z %in% names(data)) { + z <- NULL } - parameters <- list( - pri = pri, - sec = sec, - ter = ter, - ... - ) - - out <- do.call( + do.call( type, - modifyList(parameters,list(data=data)) + list(data, x, y, z, ...) ) - - code <- rlang::call2(type,!!!parameters,.ns = "FreesearchR") - - attr(out,"code") <- code - out } #' Print label, and if missing print variable name @@ -675,8 +666,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(force = TRUE) -line_break <- function(data, lineLength = 20, force = FALSE) { +#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(fixed = TRUE) +line_break <- function(data, lineLength = 20, fixed = FALSE) { if (isTRUE(force)) { gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), "\\1\n", data) } else { @@ -707,7 +698,7 @@ wrap_plot_list <- function(data, tag_levels = NULL) { .x } })() |> - align_axes() |> + allign_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) @@ -722,21 +713,19 @@ wrap_plot_list <- function(data, tag_levels = NULL) { } -#' Aligns axes between plots +#' Alligns axes between plots #' #' @param ... ggplot2 objects or list of ggplot2 objects #' #' @returns list of ggplot2 objects #' @export #' -align_axes <- function(...) { +allign_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") @@ -748,7 +737,7 @@ align_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 d906c766..125c3e37 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( - "%s has %s observations and %s variables, with %s (%s%%) complete cases.", + i18n("%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 45b48860..09ab6c80 100644 --- a/R/plot_box.R +++ b/R/plot_box.R @@ -6,13 +6,13 @@ #' @name data-plots #' #' @examples -#' mtcars |> plot_box(pri = "mpg", sec = "cyl", ter = "gear") +#' mtcars |> plot_box(x = "mpg", y = "cyl", z = "gear") #' mtcars |> #' default_parsing() |> -#' 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]) +#' 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]) } else { ds <- list(data) } @@ -20,12 +20,13 @@ plot_box <- function(data, pri, sec, ter = NULL) { out <- lapply(ds, \(.ds){ plot_box_single( data = .ds, - pri = pri, - sec = sec + x = x, + y = y ) }) wrap_plot_list(out) + # patchwork::wrap_plots(out,guides = "collect") } @@ -40,18 +41,18 @@ plot_box <- function(data, pri, sec, ter = NULL) { #' #' @examples #' mtcars |> plot_box_single("mpg","cyl") -plot_box_single <- function(data, pri, sec=NULL, seed = 2103) { +plot_box_single <- function(data, x, y=NULL, seed = 2103) { set.seed(seed) - if (is.null(sec)) { - sec <- "All" - data[[y]] <- sec + if (is.null(y)) { + y <- "All" + data[[y]] <- y } - discrete <- !data_type(data[[sec]]) %in% "continuous" + discrete <- !data_type(data[[y]]) %in% "continuous" data |> - ggplot2::ggplot(ggplot2::aes(x = !!dplyr::sym(pri), y = !!dplyr::sym(sec), fill = !!dplyr::sym(sec), group = !!dplyr::sym(sec))) + + ggplot2::ggplot(ggplot2::aes(x = !!dplyr::sym(x), y = !!dplyr::sym(y), fill = !!dplyr::sym(y), group = !!dplyr::sym(y))) + 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 36c8f918..88ce437f 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, pri, sec, ter = NULL, seed = 2103) { +plot_euler <- function(data, x, y, z = NULL, seed = 2103) { set.seed(seed = seed) - if (!is.null(ter)) { - ds <- split(data, data[ter]) + if (!is.null(z)) { + ds <- split(data, data[z]) } else { ds <- list(data) } out <- lapply(ds, \(.x){ - .x[c(pri, sec)] |> + .x[c(x, y)] |> as.data.frame() |> plot_euler_single() }) @@ -95,6 +95,7 @@ plot_euler <- function(data, pri, sec, ter = 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 84ead0da..4f322fa3 100644 --- a/R/plot_hbar.R +++ b/R/plot_hbar.R @@ -6,10 +6,10 @@ #' @name data-plots #' #' @examples -#' 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) +#' 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) out } diff --git a/R/plot_sankey.R b/R/plot_sankey.R index 55a0b4e3..baddb7f9 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, pri, sec, numbers = "count", ...) { +sankey_ready <- function(data, x, y, numbers = "count", ...) { ## TODO: Ensure ordering x and y ## Ensure all are factors - data[c(pri, sec)] <- data[c(pri, sec)] |> + data[c(x, y)] <- data[c(x, y)] |> dplyr::mutate(dplyr::across(!dplyr::where(is.factor), forcats::as_factor)) - out <- dplyr::count(data, !!dplyr::sym(pri), !!dplyr::sym(sec)) + out <- dplyr::count(data, !!dplyr::sym(x), !!dplyr::sym(y)) out <- out |> - dplyr::group_by(!!dplyr::sym(pri)) |> + dplyr::group_by(!!dplyr::sym(x)) |> dplyr::mutate(gx.sum = sum(n)) |> dplyr::ungroup() |> - dplyr::group_by(!!dplyr::sym(sec)) |> + dplyr::group_by(!!dplyr::sym(y)) |> dplyr::mutate(gy.sum = sum(n)) |> dplyr::ungroup() if (numbers == "count") { out <- out |> dplyr::mutate( - lx = factor(paste0(!!dplyr::sym(pri), "\n(n=", gx.sum, ")")), - ly = factor(paste0(!!dplyr::sym(sec), "\n(n=", gy.sum, ")")) + lx = factor(paste0(!!dplyr::sym(x), "\n(n=", gx.sum, ")")), + ly = factor(paste0(!!dplyr::sym(y), "\n(n=", gy.sum, ")")) ) } else if (numbers == "percentage") { out <- out |> dplyr::mutate( - lx = factor(paste0(!!dplyr::sym(pri), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)")), - ly = factor(paste0(!!dplyr::sym(sec), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)")) + lx = factor(paste0(!!dplyr::sym(x), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)")), + ly = factor(paste0(!!dplyr::sym(y), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)")) ) } - if (is.factor(data[[pri]])) { - index <- match(levels(data[[pri]]), str_remove_last(levels(out$lx), "\n")) + if (is.factor(data[[x]])) { + index <- match(levels(data[[x]]), str_remove_last(levels(out$lx), "\n")) out$lx <- factor(out$lx, levels = levels(out$lx)[index]) } - if (is.factor(data[[sec]])) { - index <- match(levels(data[[sec]]), str_remove_last(levels(out$ly), "\n")) + if (is.factor(data[[y]])) { + index <- match(levels(data[[y]]), str_remove_last(levels(out$ly), "\n")) out$ly <- factor(out$ly, levels = levels(out$ly)[index]) } @@ -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, pri, sec, ter = NULL, color.group = "x", colors = NULL) { - if (!is.null(ter)) { - ds <- split(data, data[ter]) +plot_sankey <- function(data, x, y, z = NULL, color.group = "x", colors = NULL) { + if (!is.null(z)) { + ds <- split(data, data[z]) } else { ds <- list(data) } out <- lapply(ds, \(.ds){ - plot_sankey_single(.ds, x = pri, y = sec, color.group = color.group, colors = colors) + plot_sankey_single(.ds, x = x, y = y, 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 = "pri") -plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), colors = NULL, ...) { +#' plot_sankey_single("first", "last", color.group = "x") +plot_sankey_single <- function(data, x, y, color.group = c("x", "y"), colors = NULL, ...) { color.group <- match.arg(color.group) - data <- data |> sankey_ready(pri = pri, sec = sec, ...) + data <- data |> sankey_ready(x = x, y = y, ...) library(ggalluvial) @@ -123,13 +123,13 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co box.color <- "#1E4B66" if (is.null(colors)) { - if (color.group == "sec") { - main.colors <- viridisLite::viridis(n = length(levels(data[[sec]]))) - secondary.colors <- rep(na.color, length(levels(data[[pri]]))) + if (color.group == "y") { + main.colors <- viridisLite::viridis(n = length(levels(data[[y]]))) + secondary.colors <- rep(na.color, length(levels(data[[x]]))) label.colors <- Reduce(c, lapply(list(secondary.colors, rev(main.colors)), contrast_text)) } else { - main.colors <- viridisLite::viridis(n = length(levels(data[[pri]]))) - secondary.colors <- rep(na.color, length(levels(data[[sec]]))) + main.colors <- viridisLite::viridis(n = length(levels(data[[x]]))) + secondary.colors <- rep(na.color, length(levels(data[[y]]))) label.colors <- Reduce(c, lapply(list(rev(main.colors), secondary.colors), contrast_text)) } colors <- c(na.color, main.colors, secondary.colors) @@ -137,33 +137,33 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co label.colors <- contrast_text(colors) } - group_labels <- c(get_label(data, pri), get_label(data, sec)) |> + group_labels <- c(get_label(data, x), get_label(data, y)) |> sapply(line_break) |> unname() p <- ggplot2::ggplot(data, ggplot2::aes(y = n, axis1 = lx, axis2 = ly)) - if (color.group == "sec") { + if (color.group == "y") { p <- p + ggalluvial::geom_alluvium( - ggplot2::aes(fill = !!dplyr::sym(sec), color = !!dplyr::sym(sec)), + ggplot2::aes(fill = !!dplyr::sym(y), color = !!dplyr::sym(y)), width = 1 / 16, alpha = .8, knot.pos = 0.4, curve_type = "sigmoid" - ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(sec)), + ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(y)), size = 2, width = 1 / 3.4 ) } else { p <- p + ggalluvial::geom_alluvium( - ggplot2::aes(fill = !!dplyr::sym(pri), color = !!dplyr::sym(pri)), + ggplot2::aes(fill = !!dplyr::sym(x), color = !!dplyr::sym(x)), width = 1 / 16, alpha = .8, knot.pos = 0.4, curve_type = "sigmoid" - ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(pri)), + ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(x)), size = 2, width = 1 / 3.4 ) diff --git a/R/plot_scatter.R b/R/plot_scatter.R index c2389b08..8f386719 100644 --- a/R/plot_scatter.R +++ b/R/plot_scatter.R @@ -6,24 +6,20 @@ #' @name data-plots #' #' @examples -#' mtcars |> plot_scatter(pri = "mpg", sec = "wt") -plot_scatter <- function(data, pri, sec, ter = NULL) { - if (is.null(ter)) { +#' mtcars |> plot_scatter(x = "mpg", y = "wt") +plot_scatter <- function(data, x, y, z = NULL) { + if (is.null(z)) { rempsyc::nice_scatter( data = data, - predictor = sec, - response = pri, - xtitle = get_label(data, var = sec), - ytitle = get_label(data, var = pri) + predictor = y, + response = x, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x) ) } else { rempsyc::nice_scatter( data = data, - predictor = sec, - response = pri, - group = ter, - xtitle = get_label(data, var = sec), - ytitle = get_label(data, var = pri) + predictor = y, + response = x, + group = z, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x) ) } } diff --git a/R/plot_violin.R b/R/plot_violin.R index e6c54346..7feabd72 100644 --- a/R/plot_violin.R +++ b/R/plot_violin.R @@ -6,10 +6,10 @@ #' @name data-plots #' #' @examples -#' 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]) +#' 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]) } else { ds <- list(data) } @@ -17,10 +17,8 @@ plot_violin <- function(data, pri, sec, ter = NULL) { out <- lapply(ds, \(.ds){ rempsyc::nice_violin( data = .ds, - group = sec, - response = pri, - xtitle = get_label(data, var = sec), - ytitle = get_label(data, var = pri) + group = y, + response = x, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x) ) }) diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index 79bc3f7b..85aef6bc 100644 --- a/inst/apps/FreesearchR/app.R +++ b/inst/apps/FreesearchR/app.R @@ -10,7 +10,7 @@ #### Current file: /Users/au301842/FreesearchR/R//app_version.R ######## -app_version <- function()'Version: 25.4.3.250415_1627' +app_version <- function()'Version: 25.4.3.250414_1342' ######## @@ -68,7 +68,7 @@ create_baseline <- function(data, ..., by.var, add.p = FALSE, add.overall = FALS } } - suppressMessages(gtsummary::theme_gtsummary_journal(journal = theme)) + gtsummary::theme_gtsummary_journal(journal = theme) args <- list(...) @@ -207,8 +207,7 @@ data_correlations_server <- function(id, } else { out <- data() } - # out |> dplyr::mutate(dplyr::across(tidyselect::everything(),as.numeric)) - sapply(out,as.numeric) + out |> dplyr::mutate(dplyr::across(tidyselect::everything(),as.numeric)) # as.numeric() }) @@ -262,9 +261,8 @@ data_correlations_server <- function(id, } correlation_pairs <- function(data, threshold = .8) { - 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)) + data <- data[!sapply(data, is.character)] + 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 |> @@ -518,7 +516,7 @@ cut_var <- function(x, ...) { #' @export #' @name cut_var cut_var.default <- function(x, ...) { - base::cut(x, ...) + base::cut.default(x, ...) } #' @name cut_var @@ -1081,6 +1079,36 @@ 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]] @@ -1099,7 +1127,6 @@ plot_histogram <- function(data, column, bins = 30, breaks = NULL, color = "#112 } - ######## #### Current file: /Users/au301842/FreesearchR/R//data_plots.R ######## @@ -1194,7 +1221,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")) @@ -1221,7 +1248,7 @@ data_visuals_server <- function(id, rv <- shiny::reactiveValues( plot.params = NULL, plot = NULL, - code = NULL + code=NULL ) # ## --- New attempt @@ -1322,7 +1349,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", @@ -1424,30 +1451,37 @@ data_visuals_server <- function(id, shiny::observeEvent(input$act_plot, { - if (NROW(data()) > 0) { - tryCatch( - { - parameters <- list( - type = rv$plot.params()[["fun"]], - pri = input$primary, - sec = input$secondary, - ter = input$tertiary - ) + if (NROW(data())>0){ + tryCatch( + { + parameters <- list( + 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")) - }) + 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 + # ) + }) - 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 ) @@ -1514,7 +1548,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] @@ -1549,21 +1583,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", @@ -1577,30 +1611,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( @@ -1611,7 +1645,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 ) ) @@ -1690,9 +1724,9 @@ get_plot_options <- function(data) { #' Wrapper to create plot based on provided type #' #' @param data data.frame -#' @param pri primary variable -#' @param sec secondary variable -#' @param ter tertiary variable +#' @param x primary variable +#' @param y secondary variable +#' @param z tertiary variable #' @param type plot type (derived from possible_plots() and matches custom function) #' @param ... ignored for now #' @@ -1702,36 +1736,20 @@ get_plot_options <- function(data) { #' @export #' #' @examples -#' 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 - } +#' create_plot(mtcars, "plot_violin", "mpg", "cyl") +create_plot <- function(data, type, x, y, z = NULL, ...) { + if (!any(y %in% names(data))) { + y <- NULL } - if (!is.null(ter)) { - if (!ter %in% names(data)) { - ter <- NULL - } + if (!z %in% names(data)) { + z <- NULL } - parameters <- list( - pri = pri, - sec = sec, - ter = ter, - ... - ) - - out <- do.call( + do.call( type, - modifyList(parameters,list(data=data)) + list(data, x, y, z, ...) ) - - code <- rlang::call2(type,!!!parameters,.ns = "FreesearchR") - - attr(out,"code") <- code - out } #' Print label, and if missing print variable name @@ -1781,8 +1799,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(force = TRUE) -line_break <- function(data, lineLength = 20, force = FALSE) { +#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(fixed = TRUE) +line_break <- function(data, lineLength = 20, fixed = FALSE) { if (isTRUE(force)) { gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), "\\1\n", data) } else { @@ -1813,7 +1831,7 @@ wrap_plot_list <- function(data, tag_levels = NULL) { .x } })() |> - align_axes() |> + allign_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) @@ -1828,21 +1846,19 @@ wrap_plot_list <- function(data, tag_levels = NULL) { } -#' Aligns axes between plots +#' Alligns axes between plots #' #' @param ... ggplot2 objects or list of ggplot2 objects #' #' @returns list of ggplot2 objects #' @export #' -align_axes <- function(...) { +allign_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") @@ -1854,7 +1870,7 @@ align_axes <- function(...) { suppressWarnings({ p |> purrr::map(~ .x + ggplot2::xlim(xr) + ggplot2::ylim(yr)) - }) + }) } #' Extract and clean axis ranges @@ -2197,8 +2213,8 @@ overview_vars <- function(data) { data <- as.data.frame(data) dplyr::tibble( - icon = data_type(data), - type = icon, + class = get_classes(data), + type = data_type(data), name = names(data), n_missing = unname(colSums(is.na(data))), p_complete = 1 - n_missing / nrow(data), @@ -2230,7 +2246,7 @@ create_overview_datagrid <- function(data,...) { std_names <- c( "Name" = "name", - "Icon" = "icon", + "Class" = "class", "Type" = "type", "Missings" = "n_missing", "Complete" = "p_complete", @@ -2268,7 +2284,7 @@ create_overview_datagrid <- function(data,...) { grid <- toastui::grid_columns( grid = grid, - columns = "icon", + columns = "class", header = " ", align = "center",sortable = FALSE, width = 40 @@ -2276,8 +2292,7 @@ create_overview_datagrid <- function(data,...) { grid <- add_class_icon( grid = grid, - column = "icon", - fun = type_icons + column = "class" ) grid <- toastui::grid_format( @@ -2314,14 +2329,32 @@ create_overview_datagrid <- function(data,...) { #' overview_vars() |> #' toastui::datagrid() |> #' add_class_icon() -add_class_icon <- function(grid, column = "class", fun=class_icons) { +add_class_icon <- function(grid, column = "class") { out <- toastui::grid_format( grid = grid, column = column, formatter = function(value) { lapply( X = value, - FUN = fun + 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") + } + } ) } ) @@ -2335,74 +2368,6 @@ add_class_icon <- function(grid, column = "class", fun=class_icons) { } -#' 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 ######## @@ -2766,7 +2731,7 @@ data_description <- function(data, data_text = "Data") { p_complete <- n_complete / n sprintf( - "%s has %s observations and %s variables, with %s (%s%%) complete cases.", + i18n("%s has %s observations and %s variables, with %s (%s%%) complete cases."), data_text, n, n_var, @@ -3668,13 +3633,13 @@ launch_FreesearchR <- function(...){ #' @name data-plots #' #' @examples -#' mtcars |> plot_box(pri = "mpg", sec = "cyl", ter = "gear") +#' mtcars |> plot_box(x = "mpg", y = "cyl", z = "gear") #' mtcars |> #' default_parsing() |> -#' 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]) +#' 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]) } else { ds <- list(data) } @@ -3682,12 +3647,13 @@ plot_box <- function(data, pri, sec, ter = NULL) { out <- lapply(ds, \(.ds){ plot_box_single( data = .ds, - pri = pri, - sec = sec + x = x, + y = y ) }) wrap_plot_list(out) + # patchwork::wrap_plots(out,guides = "collect") } @@ -3702,18 +3668,18 @@ plot_box <- function(data, pri, sec, ter = NULL) { #' #' @examples #' mtcars |> plot_box_single("mpg","cyl") -plot_box_single <- function(data, pri, sec=NULL, seed = 2103) { +plot_box_single <- function(data, x, y=NULL, seed = 2103) { set.seed(seed) - if (is.null(sec)) { - sec <- "All" - data[[y]] <- sec + if (is.null(y)) { + y <- "All" + data[[y]] <- y } - discrete <- !data_type(data[[sec]]) %in% "continuous" + discrete <- !data_type(data[[y]]) %in% "continuous" data |> - ggplot2::ggplot(ggplot2::aes(x = !!dplyr::sym(pri), y = !!dplyr::sym(sec), fill = !!dplyr::sym(sec), group = !!dplyr::sym(sec))) + + ggplot2::ggplot(ggplot2::aes(x = !!dplyr::sym(x), y = !!dplyr::sym(y), fill = !!dplyr::sym(y), group = !!dplyr::sym(y))) + 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) + @@ -3823,16 +3789,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, pri, sec, ter = NULL, seed = 2103) { +plot_euler <- function(data, x, y, z = NULL, seed = 2103) { set.seed(seed = seed) - if (!is.null(ter)) { - ds <- split(data, data[ter]) + if (!is.null(z)) { + ds <- split(data, data[z]) } else { ds <- list(data) } out <- lapply(ds, \(.x){ - .x[c(pri, sec)] |> + .x[c(x, y)] |> as.data.frame() |> plot_euler_single() }) @@ -3842,6 +3808,7 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) { # patchwork::wrap_plots(out, guides = "collect") } +?withCallingHandlers() #' Easily plot single euler diagrams #' #' @returns ggplot2 object @@ -3887,10 +3854,10 @@ plot_euler_single <- function(data) { #' @name data-plots #' #' @examples -#' 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) +#' 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) out } @@ -4031,42 +3998,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, pri, sec, numbers = "count", ...) { +sankey_ready <- function(data, x, y, numbers = "count", ...) { ## TODO: Ensure ordering x and y ## Ensure all are factors - data[c(pri, sec)] <- data[c(pri, sec)] |> + data[c(x, y)] <- data[c(x, y)] |> dplyr::mutate(dplyr::across(!dplyr::where(is.factor), forcats::as_factor)) - out <- dplyr::count(data, !!dplyr::sym(pri), !!dplyr::sym(sec)) + out <- dplyr::count(data, !!dplyr::sym(x), !!dplyr::sym(y)) out <- out |> - dplyr::group_by(!!dplyr::sym(pri)) |> + dplyr::group_by(!!dplyr::sym(x)) |> dplyr::mutate(gx.sum = sum(n)) |> dplyr::ungroup() |> - dplyr::group_by(!!dplyr::sym(sec)) |> + dplyr::group_by(!!dplyr::sym(y)) |> dplyr::mutate(gy.sum = sum(n)) |> dplyr::ungroup() if (numbers == "count") { out <- out |> dplyr::mutate( - lx = factor(paste0(!!dplyr::sym(pri), "\n(n=", gx.sum, ")")), - ly = factor(paste0(!!dplyr::sym(sec), "\n(n=", gy.sum, ")")) + lx = factor(paste0(!!dplyr::sym(x), "\n(n=", gx.sum, ")")), + ly = factor(paste0(!!dplyr::sym(y), "\n(n=", gy.sum, ")")) ) } else if (numbers == "percentage") { out <- out |> dplyr::mutate( - lx = factor(paste0(!!dplyr::sym(pri), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)")), - ly = factor(paste0(!!dplyr::sym(sec), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)")) + lx = factor(paste0(!!dplyr::sym(x), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)")), + ly = factor(paste0(!!dplyr::sym(y), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)")) ) } - if (is.factor(data[[pri]])) { - index <- match(levels(data[[pri]]), str_remove_last(levels(out$lx), "\n")) + if (is.factor(data[[x]])) { + index <- match(levels(data[[x]]), str_remove_last(levels(out$lx), "\n")) out$lx <- factor(out$lx, levels = levels(out$lx)[index]) } - if (is.factor(data[[sec]])) { - index <- match(levels(data[[sec]]), str_remove_last(levels(out$ly), "\n")) + if (is.factor(data[[y]])) { + index <- match(levels(data[[y]]), str_remove_last(levels(out$ly), "\n")) out$ly <- factor(out$ly, levels = levels(out$ly)[index]) } @@ -4091,15 +4058,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, pri, sec, ter = NULL, color.group = "x", colors = NULL) { - if (!is.null(ter)) { - ds <- split(data, data[ter]) +plot_sankey <- function(data, x, y, z = NULL, color.group = "x", colors = NULL) { + if (!is.null(z)) { + ds <- split(data, data[z]) } else { ds <- list(data) } out <- lapply(ds, \(.ds){ - plot_sankey_single(.ds, x = pri, y = sec, color.group = color.group, colors = colors) + plot_sankey_single(.ds, x = x, y = y, color.group = color.group, colors = colors) }) patchwork::wrap_plots(out) @@ -4128,10 +4095,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 = "pri") -plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), colors = NULL, ...) { +#' plot_sankey_single("first", "last", color.group = "x") +plot_sankey_single <- function(data, x, y, color.group = c("x", "y"), colors = NULL, ...) { color.group <- match.arg(color.group) - data <- data |> sankey_ready(pri = pri, sec = sec, ...) + data <- data |> sankey_ready(x = x, y = y, ...) library(ggalluvial) @@ -4139,13 +4106,13 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co box.color <- "#1E4B66" if (is.null(colors)) { - if (color.group == "sec") { - main.colors <- viridisLite::viridis(n = length(levels(data[[sec]]))) - secondary.colors <- rep(na.color, length(levels(data[[pri]]))) + if (color.group == "y") { + main.colors <- viridisLite::viridis(n = length(levels(data[[y]]))) + secondary.colors <- rep(na.color, length(levels(data[[x]]))) label.colors <- Reduce(c, lapply(list(secondary.colors, rev(main.colors)), contrast_text)) } else { - main.colors <- viridisLite::viridis(n = length(levels(data[[pri]]))) - secondary.colors <- rep(na.color, length(levels(data[[sec]]))) + main.colors <- viridisLite::viridis(n = length(levels(data[[x]]))) + secondary.colors <- rep(na.color, length(levels(data[[y]]))) label.colors <- Reduce(c, lapply(list(rev(main.colors), secondary.colors), contrast_text)) } colors <- c(na.color, main.colors, secondary.colors) @@ -4153,33 +4120,33 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co label.colors <- contrast_text(colors) } - group_labels <- c(get_label(data, pri), get_label(data, sec)) |> + group_labels <- c(get_label(data, x), get_label(data, y)) |> sapply(line_break) |> unname() p <- ggplot2::ggplot(data, ggplot2::aes(y = n, axis1 = lx, axis2 = ly)) - if (color.group == "sec") { + if (color.group == "y") { p <- p + ggalluvial::geom_alluvium( - ggplot2::aes(fill = !!dplyr::sym(sec), color = !!dplyr::sym(sec)), + ggplot2::aes(fill = !!dplyr::sym(y), color = !!dplyr::sym(y)), width = 1 / 16, alpha = .8, knot.pos = 0.4, curve_type = "sigmoid" - ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(sec)), + ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(y)), size = 2, width = 1 / 3.4 ) } else { p <- p + ggalluvial::geom_alluvium( - ggplot2::aes(fill = !!dplyr::sym(pri), color = !!dplyr::sym(pri)), + ggplot2::aes(fill = !!dplyr::sym(x), color = !!dplyr::sym(x)), width = 1 / 16, alpha = .8, knot.pos = 0.4, curve_type = "sigmoid" - ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(pri)), + ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(x)), size = 2, width = 1 / 3.4 ) @@ -4228,24 +4195,20 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co #' @name data-plots #' #' @examples -#' mtcars |> plot_scatter(pri = "mpg", sec = "wt") -plot_scatter <- function(data, pri, sec, ter = NULL) { - if (is.null(ter)) { +#' mtcars |> plot_scatter(x = "mpg", y = "wt") +plot_scatter <- function(data, x, y, z = NULL) { + if (is.null(z)) { rempsyc::nice_scatter( data = data, - predictor = sec, - response = pri, - xtitle = get_label(data, var = sec), - ytitle = get_label(data, var = pri) + predictor = y, + response = x, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x) ) } else { rempsyc::nice_scatter( data = data, - predictor = sec, - response = pri, - group = ter, - xtitle = get_label(data, var = sec), - ytitle = get_label(data, var = pri) + predictor = y, + response = x, + group = z, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x) ) } } @@ -4263,10 +4226,10 @@ plot_scatter <- function(data, pri, sec, ter = NULL) { #' @name data-plots #' #' @examples -#' 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]) +#' 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]) } else { ds <- list(data) } @@ -4274,10 +4237,8 @@ plot_violin <- function(data, pri, sec, ter = NULL) { out <- lapply(ds, \(.ds){ rempsyc::nice_violin( data = .ds, - group = sec, - response = pri, - xtitle = get_label(data, var = sec), - ytitle = get_label(data, var = pri) + group = y, + response = x, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x) ) }) diff --git a/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf b/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf index 464b7ee6..793c917f 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: 10119038 +bundleId: 10111887 url: https://agdamsbo.shinyapps.io/freesearcheR/ version: 1 diff --git a/man/add_class_icon.Rd b/man/add_class_icon.Rd index a35b6211..e21aeb3c 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", fun = class_icons) +add_class_icon(grid, column = "class") } \arguments{ \item{grid}{grid} diff --git a/man/align_axes.Rd b/man/allign_axes.Rd similarity index 65% rename from man/align_axes.Rd rename to man/allign_axes.Rd index 01a43a3b..5bb4a39e 100644 --- a/man/align_axes.Rd +++ b/man/allign_axes.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/data_plots.R -\name{align_axes} -\alias{align_axes} -\title{Aligns axes between plots} +\name{allign_axes} +\alias{allign_axes} +\title{Alligns axes between plots} \usage{ -align_axes(...) +allign_axes(...) } \arguments{ \item{...}{ggplot2 objects or list of ggplot2 objects} @@ -13,5 +13,5 @@ align_axes(...) list of ggplot2 objects } \description{ -Aligns axes between plots +Alligns axes between plots } diff --git a/man/argsstring2list.Rd b/man/argsstring2list.Rd index 70be11c8..48639a0b 100644 --- a/man/argsstring2list.Rd +++ b/man/argsstring2list.Rd @@ -15,7 +15,3 @@ 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 deleted file mode 100644 index a21c3e62..00000000 --- a/man/class_icons.Rd +++ /dev/null @@ -1,21 +0,0 @@ -% 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 4c13ff3c..11789177 100644 --- a/man/create_baseline.Rd +++ b/man/create_baseline.Rd @@ -32,5 +32,4 @@ 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 6403fa7f..1c034b1a 100644 --- a/man/cut-variable.Rd +++ b/man/cut-variable.Rd @@ -5,6 +5,7 @@ \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) @@ -18,6 +19,13 @@ 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.} @@ -39,6 +47,10 @@ 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 171c45f9..f580b0e0 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, pri, sec, ter = NULL, ...) +create_plot(data, type, x, y, z = NULL, ...) -plot_box(data, pri, sec, ter = NULL) +plot_box(data, x, y, z = NULL) -plot_box_single(data, pri, sec = NULL, seed = 2103) +plot_box_single(data, x, y = NULL, seed = 2103) -plot_hbars(data, pri, sec, ter = NULL) +plot_hbars(data, x, y, z = NULL) plot_ridge(data, x, y, z = NULL, ...) -sankey_ready(data, pri, sec, numbers = "count", ...) +sankey_ready(data, x, y, numbers = "count", ...) -plot_sankey(data, pri, sec, ter = NULL, color.group = "x", colors = NULL) +plot_sankey(data, x, y, z = NULL, color.group = "x", colors = NULL) -plot_scatter(data, pri, sec, ter = NULL) +plot_scatter(data, x, y, z = NULL) -plot_violin(data, pri, sec, ter = NULL) +plot_violin(data, x, y, z = NULL) } \arguments{ \item{id}{Module id. (Use 'ns("id")')} @@ -47,11 +47,11 @@ plot_violin(data, pri, sec, ter = NULL) \item{type}{plot type (derived from possible_plots() and matches custom function)} -\item{pri}{primary variable} +\item{x}{primary variable} -\item{sec}{secondary variable} +\item{y}{secondary variable} -\item{ter}{tertiary variable} +\item{z}{tertiary variable} } \value{ Shiny ui module @@ -98,14 +98,14 @@ Beautiful violin plot Beatiful violin plot } \examples{ -create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes() -mtcars |> plot_box(pri = "mpg", sec = "cyl", ter = "gear") +create_plot(mtcars, "plot_violin", "mpg", "cyl") +mtcars |> plot_box(x = "mpg", y = "cyl", z = "gear") mtcars |> default_parsing() |> - plot_box(pri = "mpg", sec = "cyl", ter = "gear") + plot_box(x = "mpg", y = "cyl", z = "gear") mtcars |> plot_box_single("mpg","cyl") -mtcars |> plot_hbars(pri = "carb", sec = "cyl") -mtcars |> plot_hbars(pri = "carb", sec = NULL) +mtcars |> plot_hbars(x = "carb", y = "cyl") +mtcars |> plot_hbars(x = "carb", y = 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(pri = "mpg", sec = "wt") -mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear") +mtcars |> plot_scatter(x = "mpg", y = "wt") +mtcars |> plot_violin(x = "mpg", y = "cyl", z = "gear") } diff --git a/man/data_type_filter.Rd b/man/data_type_filter.Rd index b6c03c07..4dab22b1 100644 --- a/man/data_type_filter.Rd +++ b/man/data_type_filter.Rd @@ -18,13 +18,8 @@ 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 = NULL) |> - attributes() +default_parsing(mtcars) |> data_type_filter(type=c("categorical","continuous")) |> 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 82719129..65e2439c 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 1ad79ca3..d66412ba 100644 --- a/man/factorize.Rd +++ b/man/factorize.Rd @@ -17,6 +17,3 @@ 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 65c987c7..c74ead08 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, force = FALSE) +line_break(data, lineLength = 20, fixed = 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(force = TRUE) +paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(fixed = TRUE) } diff --git a/man/plot_euler.Rd b/man/plot_euler.Rd index 2785047a..78f3333d 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, pri, sec, ter = NULL, seed = 2103) +plot_euler(data, x, y, z = 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 0c48fde1..b1410f76 100644 --- a/man/plot_sankey_single.Rd +++ b/man/plot_sankey_single.Rd @@ -4,14 +4,7 @@ \alias{plot_sankey_single} \title{Beautiful sankey plot} \usage{ -plot_sankey_single( - data, - pri, - sec, - color.group = c("pri", "sec"), - colors = NULL, - ... -) +plot_sankey_single(data, x, y, color.group = c("x", "y"), colors = NULL, ...) } \arguments{ \item{color.group}{set group to colour by. "x" or "y".} @@ -36,5 +29,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 = "pri") + plot_sankey_single("first", "last", color.group = "x") } diff --git a/man/remove_empty_attr.Rd b/man/remove_empty_attr.Rd index 68155680..39f3cc41 100644 --- a/man/remove_empty_attr.Rd +++ b/man/remove_empty_attr.Rd @@ -15,12 +15,3 @@ 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 new file mode 100644 index 00000000..41bb4ee2 --- /dev/null +++ b/man/remove_na_attr.Rd @@ -0,0 +1,23 @@ +% 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 716a982e..73633191 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, like when uploading .rds} +\title{Very simple function to remove nested lists, lik ewhen 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, like when uploading .rds +Very simple function to remove nested lists, lik ewhen 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 c1a7ef9a..7b3f3665 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 deleted file mode 100644 index 54c46b2d..00000000 --- a/man/type_icons.Rd +++ /dev/null @@ -1,21 +0,0 @@ -% 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 940fd4ec..7fd7562c 100644 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -8,6 +8,5 @@ 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 deleted file mode 100644 index 258000c3..00000000 --- a/tests/testthat/_snaps/contrast_text.md +++ /dev/null @@ -1,23 +0,0 @@ -# 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 deleted file mode 100644 index 6a69f86d..00000000 --- a/tests/testthat/_snaps/data_plots.md +++ /dev/null @@ -1,160 +0,0 @@ -# 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 deleted file mode 100644 index 312df323..00000000 --- a/tests/testthat/_snaps/helpers.md +++ /dev/null @@ -1,532 +0,0 @@ -# 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 e36ebd17..089104c3 100644 --- a/tests/testthat/test-baseline_table.R +++ b/tests/testthat/test-baseline_table.R @@ -3,26 +3,44 @@ test_that("Creates correct table",{ ## This is by far the easiest way to test all functions. Based on examples. - tbl <- create_baseline(mtcars,by.var = "gear", add.p = "yes" == "yes",add.overall = TRUE, theme = "lancet") + 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")) +}) - expect_equal(length(tbl),5) +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(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 deleted file mode 100644 index 30478c13..00000000 --- a/tests/testthat/test-correlations-module.R +++ /dev/null @@ -1,17 +0,0 @@ -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 6c8bb33b..044a8bac 100644 --- a/tests/testthat/test-custom_SelectInput.R +++ b/tests/testthat/test-custom_SelectInput.R @@ -1,83 +1,3 @@ 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({ - 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") - }) + expect_snapshot(columnSelectInput("x",label = "X",data = mtcars)) }) diff --git a/tests/testthat/test-cut-variable-dates.R b/tests/testthat/test-cut-variable-dates.R deleted file mode 100644 index 694a6688..00000000 --- a/tests/testthat/test-cut-variable-dates.R +++ /dev/null @@ -1,47 +0,0 @@ -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 deleted file mode 100644 index a173d378..00000000 --- a/tests/testthat/test-data_plots.R +++ /dev/null @@ -1,85 +0,0 @@ -## 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)) -})