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 |>
-    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)) {

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
 #'