docs + tests

R/app_version.R

@@ -1 +1 @@
-app_version <- function()'Version: 25.4.3.250414_1045'
+app_version <- function()'Version: 25.4.3.250414_1342'

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 |>
+  args <- list(...)
-    baseline_table(
+
-      fun.args =
+  parameters <- list(
-        list(
+    data = data,
-          by = by.var,
+    fun.args = list(by = by.var, ...)
-          ...
+  )
-        )
+
-    )
+  out <- do.call(
+    baseline_table,
+    parameters
+  )
+
 
   if (!is.null(by.var)) {
     if (isTRUE(add.overall)) {

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") {
+#'  mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x, label = NA, attr = "label")) |> remove_empty_attr() |>
-  out <- data |> lapply(\(.x){
+#'   str()
-    ls <- REDCapCAST::get_attr(data = .x, attr = attr)
+#'
-    if (is.na(ls) | ls == "") {
+remove_empty_attr <- function(data) {
-      attr(x = .x, which = attr) <- NULL
+  if (is.data.frame(data)){
-    }
+    data |> lapply(remove_empty_attr) |> dplyr::bind_cols()
-    .x
+  } else if (is.list(data)){
-  })
+    data |> lapply(remove_empty_attr)
-
+  }else{
-  dplyr::bind_cols(out)
+  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]
+  if (!is.null(type)) {
-  code <- rlang::call2("data_type_filter",!!!list(type=type),.ns = "FreesearchR")
+    out <- data[data_type(data) %in% type]
-  attr(out, "code") <- code
+    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
 #'

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/)
 <!-- badges: end -->
 
-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. Any suggestions on collaboration is much welcomed. Please reach out!
-
-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.
 
 ## 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
 

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 |>
+  args <- list(...)
-    baseline_table(
+
-      fun.args =
+  parameters <- list(
-        list(
+    data = data,
-          by = by.var,
+    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")) {
+  if ("format" %in% names(args)){
-    days <- c(
+    assertthat::assert_that(is.character(args$format))
-      "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday",
+    out <- forcats::as_factor(format(x,format=args$format))
-      "Sunday"
+  } else if (identical(breaks, "weekday")) {
-    )
+    ## This is
-    if (!start.on.monday) {
+    ds <- as.Date(1:7) |>
-      days <- days[c(7, 1:6)]
+      (\(.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")) {
+  if ("format" %in% names(args)){
-    days <- c(
+    assertthat::assert_that(is.character(args$format))
-      "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday",
+    out <- forcats::as_factor(format(x,format=args$format))
-      "Sunday"
+  } else if (identical(breaks, "weekday")) {
-    )
+    ds <- as.Date(1:7) |>
-    if (!start.on.monday) {
+      (\(.x){
-      days <- days[c(7, 1:6)]
+        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") {
+#'  mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x, label = NA, attr = "label")) |> remove_empty_attr() |>
-  out <- data |> lapply(\(.x){
+#'   str()
-    ls <- REDCapCAST::get_attr(data = .x, attr = attr)
+#'
-    if (is.na(ls) | ls == "") {
+remove_empty_attr <- function(data) {
-      attr(x = .x, which = attr) <- NULL
+  if (is.data.frame(data)){
-    }
+    data |> lapply(remove_empty_attr) |> dplyr::bind_cols()
-    .x
+  } else if (is.list(data)){
-  })
+    data |> lapply(remove_empty_attr)
-
+  }else{
-  dplyr::bind_cols(out)
+  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]
+  if (!is.null(type)) {
-  code <- rlang::call2("data_type_filter",!!!list(type=type),.ns = "FreesearchR")
+    out <- data[data_type(data) %in% type]
-  attr(out, "code") <- code
+    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(
+  shiny::observe({
-    input$column_filter # ,
+    # shiny::req(input$column_filter)
-    # rv$data
-  ), {
-    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")]

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

inst/apps/FreesearchR/server.R

@@ -366,14 +366,13 @@ server <- function(input, output, session) {
     )
   })
 
-  shiny::observeEvent(list(
+  shiny::observe({
-    input$column_filter # ,
+    # shiny::req(input$column_filter)
-    # rv$data
-  ), {
-    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")]

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")
 }

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", {

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)
+  )
+})

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")
+  )
+})