diff --git a/R/app_version.R b/R/app_version.R index 6587a1c..09283d3 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'Version: 25.4.3.250414_1045' +app_version <- function()'Version: 25.4.3.250414_1342' diff --git a/R/baseline_table.R b/R/baseline_table.R index bc3bec5..4eaccde 100644 --- a/R/baseline_table.R +++ b/R/baseline_table.R @@ -12,9 +12,6 @@ #' mtcars |> baseline_table() #' mtcars |> baseline_table(fun.args = list(by = "gear")) baseline_table <- function(data, fun.args = NULL, fun = gtsummary::tbl_summary, vars = NULL) { - if (!is.null(vars)) { - data <- data |> dplyr::select(dplyr::all_of(vars)) - } out <- do.call(fun, c(list(data = data), fun.args)) return(out) @@ -35,7 +32,8 @@ baseline_table <- function(data, fun.args = NULL, fun = gtsummary::tbl_summary, #' #' @examples #' mtcars |> create_baseline(by.var = "gear", add.p = "yes" == "yes") -create_baseline <- function(data, ..., by.var, add.p = FALSE, add.overall = FALSE, theme=c("jama", "lancet", "nejm", "qjecon")) { +#' create_baseline(default_parsing(mtcars), by.var = "am", add.p = FALSE, add.overall = FALSE, theme = "lancet") +create_baseline <- function(data, ..., by.var, add.p = FALSE, add.overall = FALSE, theme = c("jama", "lancet", "nejm", "qjecon")) { theme <- match.arg(theme) if (by.var == "none" | !by.var %in% names(data)) { @@ -53,14 +51,18 @@ create_baseline <- function(data, ..., by.var, add.p = FALSE, add.overall = FALS gtsummary::theme_gtsummary_journal(journal = theme) - out <- data |> - baseline_table( - fun.args = - list( - by = by.var, - ... - ) - ) + args <- list(...) + + parameters <- list( + data = data, + fun.args = list(by = by.var, ...) + ) + + out <- do.call( + baseline_table, + parameters + ) + if (!is.null(by.var)) { if (isTRUE(add.overall)) { diff --git a/R/helpers.R b/R/helpers.R index 3a5cf37..125c3e3 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -112,6 +112,9 @@ read_input <- function(file, consider.na = c("NA", '""', "")) { #' @return list #' @export #' +#' @examples +#' argsstring2list("A=1:5,b=2:4") +#' argsstring2list <- function(string) { eval(parse(text = paste0("list(", string, ")"))) } @@ -124,6 +127,9 @@ argsstring2list <- function(string) { #' #' @return data.frame #' @export +#' +#' @examples +#' factorize(mtcars,names(mtcars)) factorize <- function(data, vars) { if (!is.null(vars)) { data |> @@ -244,28 +250,30 @@ default_parsing <- function(data) { # ) |> dplyr::bind_cols() } -#' Remove NA labels +#' Remove empty/NA attributes #' #' @param data data #' -#' @returns data.frame +#' @returns data of same class as input #' @export #' #' @examples -#' ds <- mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x, label = NA, attr = "label")) +#' ds <- mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x, label = NA, attr = "label")) |> dplyr::bind_cols() #' ds |> -#' remove_na_attr() |> +#' remove_empty_attr() |> #' str() -remove_na_attr <- function(data, attr = "label") { - out <- data |> lapply(\(.x){ - ls <- REDCapCAST::get_attr(data = .x, attr = attr) - if (is.na(ls) | ls == "") { - attr(x = .x, which = attr) <- NULL - } - .x - }) - - dplyr::bind_cols(out) +#' mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x, label = NA, attr = "label")) |> remove_empty_attr() |> +#' str() +#' +remove_empty_attr <- function(data) { + if (is.data.frame(data)){ + data |> lapply(remove_empty_attr) |> dplyr::bind_cols() + } else if (is.list(data)){ + data |> lapply(remove_empty_attr) + }else{ + attributes(data)[is.na(attributes(data))] <- NULL + data + } } #' Removes columns with completenes below cutoff @@ -368,17 +376,26 @@ data_description <- function(data, data_text = "Data") { #' @export #' #' @examples -#' default_parsing(mtcars) |> data_type_filter(type=c("categorical","continuous")) |> attributes() +#' default_parsing(mtcars) |> +#' data_type_filter(type = c("categorical", "continuous")) |> +#' attributes() +#' default_parsing(mtcars) |> +#' data_type_filter(type = NULL) |> +#' attributes() #' \dontrun{ -#' default_parsing(mtcars) |> data_type_filter(type=c("test","categorical","continuous")) +#' default_parsing(mtcars) |> data_type_filter(type = c("test", "categorical", "continuous")) #' } -data_type_filter <- function(data,type){ +data_type_filter <- function(data, type) { ## Please ensure to only provide recognised data types assertthat::assert_that(all(type %in% data_types())) - out <- data[data_type(data) %in% type] - code <- rlang::call2("data_type_filter",!!!list(type=type),.ns = "FreesearchR") - attr(out, "code") <- code + if (!is.null(type)) { + out <- data[data_type(data) %in% type] + code <- rlang::call2("data_type_filter", !!!list(type = type), .ns = "FreesearchR") + attr(out, "code") <- code + } else { + out <- data + } out } @@ -488,7 +505,7 @@ pipe_string <- function(data, collapse = "|>\n") { #' #' @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") #' ) |> @@ -502,7 +519,7 @@ expression_string <- function(data, assign.str = "") { } -#' Very simple function to remove nested lists, lik ewhen uploading .rds +#' Very simple function to remove nested lists, like when uploading .rds #' #' @param data data #' @@ -549,19 +566,6 @@ set_column_label <- function(data, label, overwrite = TRUE) { }) |> dplyr::bind_cols(.name_repair = "unique_quiet") } -#' Remove empty/NA attributes -#' -#' @param data data -#' -#' @returns data of same class as input -#' @export -#' -remove_empty_attr <- function(data) { - attributes(data)[is.na(attributes(data))] <- NULL - data -} - - #' Append a column to a data.frame #' diff --git a/README.md b/README.md index 2ef78f1..ffa716b 100644 --- a/README.md +++ b/README.md @@ -7,18 +7,19 @@ [![FreesearchR](https://img.shields.io/badge/Shiny-shinyapps.io-blue?style=flat&labelColor=white&logo=RStudio&logoColor=blue)](https://agdamsbo.shinyapps.io/freesearcheR/) -This package is the backbone of the ***FreesearchR***, a free and open-source browser based data exploration and analysis tool for clinicians and researchers with publication ready output. +This package is the backbone of the ***FreesearchR***, a free and open-source browser based data exploration and analysis tool intended to democratise clinical research by assisting any researcher to easily evaluate and analyse data and export publication ready results. -This package and the ***FreesearchR***-tool is part of a larger initiative to democratize health data analysis and remove barriers for clinicians to engage in health research. - -the ***FreesearchR***-tool is online and accessible here: [link to the app freely hosted on shinyapps.io](https://agdamsbo.shinyapps.io/FreesearcheR/). All feedback is welcome and can be shared as a GitHub issue. - -Initiatives for funding continued development of the tool and surrounding initiatives is ongoing. +The ***FreesearchR***-tool is online and accessible here: [link to the app freely hosted on shinyapps.io](https://agdamsbo.shinyapps.io/FreesearcheR/). All feedback is welcome and can be shared as a GitHub issue. Any suggestions on collaboration is much welcomed. Please reach out! ## Motivation +This app has the following simple goals: +1. help the health clinician getting an overview of data in quality improvement projects and clinical research +1. help learners get a good start analysing data and coding in *R* + +1. ease quick data overview and basic visualisations for any clinical researcher ## Install locally diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index 8f9beb5..85aef6b 100644 --- a/inst/apps/FreesearchR/app.R +++ b/inst/apps/FreesearchR/app.R @@ -10,7 +10,7 @@ #### Current file: /Users/au301842/FreesearchR/R//app_version.R ######## -app_version <- function()'Version: 25.4.3.250414_1045' +app_version <- function()'Version: 25.4.3.250414_1342' ######## @@ -31,9 +31,6 @@ app_version <- function()'Version: 25.4.3.250414_1045' #' mtcars |> baseline_table() #' mtcars |> baseline_table(fun.args = list(by = "gear")) baseline_table <- function(data, fun.args = NULL, fun = gtsummary::tbl_summary, vars = NULL) { - if (!is.null(vars)) { - data <- data |> dplyr::select(dplyr::all_of(vars)) - } out <- do.call(fun, c(list(data = data), fun.args)) return(out) @@ -54,7 +51,8 @@ baseline_table <- function(data, fun.args = NULL, fun = gtsummary::tbl_summary, #' #' @examples #' mtcars |> create_baseline(by.var = "gear", add.p = "yes" == "yes") -create_baseline <- function(data, ..., by.var, add.p = FALSE, add.overall = FALSE, theme=c("jama", "lancet", "nejm", "qjecon")) { +#' create_baseline(default_parsing(mtcars), by.var = "am", add.p = FALSE, add.overall = FALSE, theme = "lancet") +create_baseline <- function(data, ..., by.var, add.p = FALSE, add.overall = FALSE, theme = c("jama", "lancet", "nejm", "qjecon")) { theme <- match.arg(theme) if (by.var == "none" | !by.var %in% names(data)) { @@ -72,14 +70,18 @@ create_baseline <- function(data, ..., by.var, add.p = FALSE, add.overall = FALS gtsummary::theme_gtsummary_journal(journal = theme) - out <- data |> - baseline_table( - fun.args = - list( - by = by.var, - ... - ) - ) + args <- list(...) + + parameters <- list( + data = data, + fun.args = list(by = by.var, ...) + ) + + out <- do.call( + baseline_table, + parameters + ) + if (!is.null(by.var)) { if (isTRUE(add.overall)) { @@ -551,8 +553,10 @@ cut_var.hms <- function(x, breaks, ...) { #' 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")) |> cut_var(2) #' 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")) |> cut_var(breaks = "weekday") #' 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")) |> cut_var(breaks = "month_only") +#' 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")) |> cut_var(breaks=NULL,format = "%A-%H") cut_var.POSIXt <- function(x, breaks, right = FALSE, include.lowest = TRUE, start.on.monday = TRUE, ...) { breaks_o <- breaks + args <- list(...) # browser() if (is.numeric(breaks)) { breaks <- quantile( @@ -564,16 +568,23 @@ cut_var.POSIXt <- function(x, breaks, right = FALSE, include.lowest = TRUE, star ) } - if (identical(breaks, "weekday")) { - days <- c( - "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", - "Sunday" - ) - if (!start.on.monday) { - days <- days[c(7, 1:6)] + if ("format" %in% names(args)){ + assertthat::assert_that(is.character(args$format)) + out <- forcats::as_factor(format(x,format=args$format)) + } else if (identical(breaks, "weekday")) { + ## This is + ds <- as.Date(1:7) |> + (\(.x){ + sort_by(format(.x,"%A"),as.numeric(format(.x,"%w"))) + })() + + if (start.on.monday) { + ds <- ds[c(7, 1:6)] } - out <- factor(weekdays(x), levels = days) |> forcats::fct_drop() + out <- factor(weekdays(x), levels = ds) |> forcats::fct_drop() } else if (identical(breaks, "month_only")) { + ## Simplest way to create a vector of all months in order + ## which will also follow the locale of the machine ms <- paste0("1970-", 1:12, "-01") |> as.Date() |> months() @@ -614,15 +625,19 @@ cut_var.POSIXct <- cut_var.POSIXt #' as.Date(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")) |> cut_var(2) #' as.Date(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")) |> cut_var(breaks = "weekday") cut_var.Date <- function(x, breaks, start.on.monday = TRUE, ...) { - if (identical(breaks, "weekday")) { - days <- c( - "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", - "Sunday" - ) - if (!start.on.monday) { - days <- days[c(7, 1:6)] + if ("format" %in% names(args)){ + assertthat::assert_that(is.character(args$format)) + out <- forcats::as_factor(format(x,format=args$format)) + } else if (identical(breaks, "weekday")) { + ds <- as.Date(1:7) |> + (\(.x){ + sort_by(format(.x,"%A"),as.numeric(format(.x,"%w"))) + })() + + if (start.on.monday) { + ds <- ds[c(7, 1:6)] } - out <- factor(weekdays(x), levels = days) |> forcats::fct_drop() + out <- factor(weekdays(x), levels = ds) |> forcats::fct_drop() } else if (identical(breaks, "month_only")) { ms <- paste0("1970-", 1:12, "-01") |> as.Date() |> @@ -2471,6 +2486,9 @@ read_input <- function(file, consider.na = c("NA", '""', "")) { #' @return list #' @export #' +#' @examples +#' argsstring2list("A=1:5,b=2:4") +#' argsstring2list <- function(string) { eval(parse(text = paste0("list(", string, ")"))) } @@ -2483,6 +2501,9 @@ argsstring2list <- function(string) { #' #' @return data.frame #' @export +#' +#' @examples +#' factorize(mtcars,names(mtcars)) factorize <- function(data, vars) { if (!is.null(vars)) { data |> @@ -2603,28 +2624,30 @@ default_parsing <- function(data) { # ) |> dplyr::bind_cols() } -#' Remove NA labels +#' Remove empty/NA attributes #' #' @param data data #' -#' @returns data.frame +#' @returns data of same class as input #' @export #' #' @examples -#' ds <- mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x, label = NA, attr = "label")) +#' ds <- mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x, label = NA, attr = "label")) |> dplyr::bind_cols() #' ds |> -#' remove_na_attr() |> +#' remove_empty_attr() |> #' str() -remove_na_attr <- function(data, attr = "label") { - out <- data |> lapply(\(.x){ - ls <- REDCapCAST::get_attr(data = .x, attr = attr) - if (is.na(ls) | ls == "") { - attr(x = .x, which = attr) <- NULL - } - .x - }) - - dplyr::bind_cols(out) +#' mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x, label = NA, attr = "label")) |> remove_empty_attr() |> +#' str() +#' +remove_empty_attr <- function(data) { + if (is.data.frame(data)){ + data |> lapply(remove_empty_attr) |> dplyr::bind_cols() + } else if (is.list(data)){ + data |> lapply(remove_empty_attr) + }else{ + attributes(data)[is.na(attributes(data))] <- NULL + data + } } #' Removes columns with completenes below cutoff @@ -2727,17 +2750,26 @@ data_description <- function(data, data_text = "Data") { #' @export #' #' @examples -#' default_parsing(mtcars) |> data_type_filter(type=c("categorical","continuous")) |> attributes() +#' default_parsing(mtcars) |> +#' data_type_filter(type = c("categorical", "continuous")) |> +#' attributes() +#' default_parsing(mtcars) |> +#' data_type_filter(type = NULL) |> +#' attributes() #' \dontrun{ -#' default_parsing(mtcars) |> data_type_filter(type=c("test","categorical","continuous")) +#' default_parsing(mtcars) |> data_type_filter(type = c("test", "categorical", "continuous")) #' } -data_type_filter <- function(data,type){ +data_type_filter <- function(data, type) { ## Please ensure to only provide recognised data types assertthat::assert_that(all(type %in% data_types())) - out <- data[data_type(data) %in% type] - code <- rlang::call2("data_type_filter",!!!list(type=type),.ns = "FreesearchR") - attr(out, "code") <- code + if (!is.null(type)) { + out <- data[data_type(data) %in% type] + code <- rlang::call2("data_type_filter", !!!list(type = type), .ns = "FreesearchR") + attr(out, "code") <- code + } else { + out <- data + } out } @@ -2847,7 +2879,7 @@ pipe_string <- function(data, collapse = "|>\n") { #' #' @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") #' ) |> @@ -2861,7 +2893,7 @@ expression_string <- function(data, assign.str = "") { } -#' Very simple function to remove nested lists, lik ewhen uploading .rds +#' Very simple function to remove nested lists, like when uploading .rds #' #' @param data data #' @@ -2908,19 +2940,6 @@ set_column_label <- function(data, label, overwrite = TRUE) { }) |> dplyr::bind_cols(.name_repair = "unique_quiet") } -#' Remove empty/NA attributes -#' -#' @param data data -#' -#' @returns data of same class as input -#' @export -#' -remove_empty_attr <- function(data) { - attributes(data)[is.na(attributes(data))] <- NULL - data -} - - #' Append a column to a data.frame #' @@ -9046,14 +9065,13 @@ server <- function(input, output, session) { ) }) - shiny::observeEvent(list( - input$column_filter # , - # rv$data - ), { - shiny::req(input$column_filter) + shiny::observe({ + # shiny::req(input$column_filter) out <- data_type_filter(rv$data, input$column_filter) rv$data_variables <- out - rv$code$variables <- attr(out, "code") + if (!is.null(input$column_filter)) { + rv$code$variables <- attr(out, "code") + } # rv$code$modify[[length(rv$code$modify) + 1]] <- attr(rv$data, "code") }) @@ -9210,7 +9228,7 @@ server <- function(input, output, session) { inputId = "strat_var", selected = "none", label = "Select variable to stratify baseline", - data = rv$data_filtered, + data = shiny::reactive(rv$data_filtered)(), col_subset = c( "none", names(rv$data_filtered)[unlist(lapply(rv$data_filtered, data_type)) %in% c("dichotomous", "categorical", "ordinal")] diff --git a/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf b/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf index 9cf3c2a..793c917 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: 10111316 +bundleId: 10111887 url: https://agdamsbo.shinyapps.io/freesearcheR/ version: 1 diff --git a/inst/apps/FreesearchR/server.R b/inst/apps/FreesearchR/server.R index eefe63d..40a5f51 100644 --- a/inst/apps/FreesearchR/server.R +++ b/inst/apps/FreesearchR/server.R @@ -366,14 +366,13 @@ server <- function(input, output, session) { ) }) - shiny::observeEvent(list( - input$column_filter # , - # rv$data - ), { - shiny::req(input$column_filter) + shiny::observe({ + # shiny::req(input$column_filter) out <- data_type_filter(rv$data, input$column_filter) rv$data_variables <- out - rv$code$variables <- attr(out, "code") + if (!is.null(input$column_filter)) { + rv$code$variables <- attr(out, "code") + } # rv$code$modify[[length(rv$code$modify) + 1]] <- attr(rv$data, "code") }) @@ -530,7 +529,7 @@ server <- function(input, output, session) { inputId = "strat_var", selected = "none", label = "Select variable to stratify baseline", - data = rv$data_filtered, + data = shiny::reactive(rv$data_filtered)(), col_subset = c( "none", names(rv$data_filtered)[unlist(lapply(rv$data_filtered, data_type)) %in% c("dichotomous", "categorical", "ordinal")] diff --git a/man/cut_var.Rd b/man/cut_var.Rd index b3291b7..e753ccd 100644 --- a/man/cut_var.Rd +++ b/man/cut_var.Rd @@ -57,6 +57,7 @@ readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "03:02:20", NA)) |> cut_ 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")) |> cut_var(2) 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")) |> cut_var(breaks = "weekday") 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")) |> cut_var(breaks = "month_only") +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")) |> cut_var(breaks=NULL,format = "\%A-\%H") as.Date(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")) |> cut_var(2) as.Date(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")) |> cut_var(breaks = "weekday") } diff --git a/tests/testthat/test-baseline_table.R b/tests/testthat/test-baseline_table.R index 7b392a9..089104c 100644 --- a/tests/testthat/test-baseline_table.R +++ b/tests/testthat/test-baseline_table.R @@ -2,7 +2,11 @@ ## test_that("Creates correct table",{ + ## This is by far the easiest way to test all functions. Based on examples. expect_snapshot(create_baseline(mtcars,by.var = "gear", add.p = "yes" == "yes",add.overall = TRUE, theme = "lancet")) + expect_snapshot(create_baseline(mtcars,by.var = "none", add.p = FALSE,add.overall = FALSE, theme = "lancet")) + expect_snapshot(create_baseline(mtcars,by.var = "test", add.p = FALSE,add.overall = FALSE, theme = "jama")) + expect_snapshot(create_baseline(default_parsing(mtcars),by.var = "am", add.p = FALSE,add.overall = FALSE, theme = "nejm")) }) test_that("Creates table", { diff --git a/tests/testthat/test-contrast_text.R b/tests/testthat/test-contrast_text.R new file mode 100644 index 0000000..fa9be0e --- /dev/null +++ b/tests/testthat/test-contrast_text.R @@ -0,0 +1,15 @@ +test_that("Contrasting works", { + colors <- c("#F2F2F2", "blue","red","black","white","gray35") + + expect_snapshot( + contrast_text(colors) + ) + + expect_snapshot( + contrast_text(colors,light_text = "blue",dark_text = "grey10", method = "relative", threshold = .1) + ) + + expect_snapshot( + contrast_text(colors,light_text = "blue",dark_text = "grey10", method = "perceived", threshold = .7) + ) +}) diff --git a/tests/testthat/test-helpers.R b/tests/testthat/test-helpers.R new file mode 100644 index 0000000..ba25709 --- /dev/null +++ b/tests/testthat/test-helpers.R @@ -0,0 +1,188 @@ +## getfun +test_that("getfun works", { + expect_snapshot( + getfun("stats::lm") + ) +}) + +## argsstring2list +test_that("argsstring2list works", { + expect_snapshot( + argsstring2list("A=1:5,b=2:4") + ) +}) + +## factorize +test_that("factorize works", { + expect_snapshot( + factorize(mtcars, names(mtcars)) + ) +}) + +## default_parsing +test_that("default_parsing works", { + expect_snapshot( + default_parsing(mtcars) + ) +}) + +## remove_empty_attr +test_that("remove_empty_attr works", { + ds <- mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x, label = NA, attr = "label")) + + expect_snapshot( + remove_empty_attr(ds) + ) + + expect_snapshot( + remove_empty_attr(dplyr::bind_cols(ds)) + ) + + expect_snapshot( + remove_empty_attr(ds[[1]]) + ) +}) +## remove_empty_cols +test_that("remove_empty_cols works", { + expect_snapshot( + data.frame(a = 1:10, b = NA, c = c(2, NA)) |> remove_empty_cols(cutoff = .5) + ) +}) +## append_list +test_that("append_list works", { + ls_d <- list(test = c(1:20)) + ls_d <- list() + + expect_snapshot( + data.frame(letters[1:20], 1:20) |> append_list(ls_d, "letters") + ) + + expect_snapshot( + letters[1:20] |> append_list(ls_d, "letters") + ) +}) + + +## missing_fraction +test_that("missing_fraction works", { + expect_snapshot( + c(NA, 1:10, rep(NA, 3)) |> missing_fraction() + ) +}) + + +## data_description +test_that("data_description works", { + expect_snapshot( + data.frame( + sample(1:8, 20, TRUE), + sample(c(1:8, NA), 20, TRUE) + ) |> data_description(data_text = "This data") + ) +}) + +## data_type_filter() + +test_that("Data type filter works", { + expect_snapshot( + default_parsing(mtcars) |> data_type_filter(type = c("categorical", "continuous")) + ) + + expect_snapshot( + default_parsing(mtcars) |> data_type_filter(type = NULL) + ) + + expect_error(default_parsing(mtcars) |> data_type_filter(type = "test")) +}) + +## sort_by +test_that("sort_by works", { + expect_snapshot( + sort_by(c("Multivariable", "Univariable"), c("Univariable", "Minimal", "Multivariable")) + ) +}) + +## if_not_missing +test_that("if_not_missing works", { + expect_snapshot( + NULL |> if_not_missing("new") + ) + + expect_snapshot( + c(2, "a", NA) |> if_not_missing() + ) + + expect_snapshot( + "See" |> if_not_missing() + ) +}) + +## merge_expression + pipe_string + expression_string +test_that("merge_expression, expression_string and pipe_string works", { + expect_snapshot( + list( + rlang::call2(.fn = "select", !!!list(c("cyl", "disp")), .ns = "dplyr"), + rlang::call2(.fn = "default_parsing", .ns = "FreesearchR") + ) |> merge_expression() + ) + + expect_snapshot( + list( + "mtcars", + rlang::call2(.fn = "select", !!!list(c("cyl", "disp")), .ns = "dplyr"), + rlang::call2(.fn = "default_parsing", .ns = "FreesearchR") + ) |> + lapply(expression_string) |> + pipe_string() |> + expression_string("data<-") + ) + + expect_snapshot( + list( + as.symbol(paste0("mtcars$", "mpg")), + rlang::call2(.fn = "select", !!!list(c("cyl", "disp")), .ns = "dplyr"), + rlang::call2(.fn = "default_parsing", .ns = "FreesearchR") + ) |> + merge_expression() |> + expression_string() + ) +}) + +## remove_nested_list +test_that("remove_nested_list works", { + expect_snapshot( + dplyr::tibble(a = 1:10, b = rep(list("a"), 10)) |> remove_nested_list() + ) + + expect_snapshot( + dplyr::tibble(a = 1:10, b = rep(list(c("a", "b")), 10)) |> + as.data.frame() |> + remove_nested_list() + ) +}) + +## set_column_label +test_that("set_column_label works", { + ls <- list("mpg" = "", "cyl" = "Cylinders", "disp" = "", "hp" = "", "drat" = "", "wt" = "", "qsec" = "", "vs" = "", "am" = "", "gear" = "", "carb" = "") + ls2 <- c("mpg" = "", "cyl" = "Cylinders", "disp" = "", "hp" = "Horses", "drat" = "", "wt" = "", "qsec" = "", "vs" = "", "am" = "", "gear" = "", "carb" = "") + ls3 <- c("mpg" = "", "cyl" = "", "disp" = "", "hp" = "Horses", "drat" = "", "wt" = "", "qsec" = "", "vs" = "", "am" = "", "gear" = "", "carb" = "") + + expect_snapshot( + mtcars |> + set_column_label(ls) |> + set_column_label(ls2) |> + set_column_label(ls3) + ) + + expect_snapshot( + rlang::expr(FreesearchR::set_column_label(label = !!ls3)) |> expression_string() + ) +}) +## append_column +test_that("append_column works", { + expect_snapshot( + mtcars |> + dplyr::mutate(mpg_cut = mpg) |> + append_column(mtcars$mpg, "mpg_cutter") + ) +})