new docs

DESCRIPTION

@@ -80,7 +80,9 @@ Suggests:
     rsconnect,
     knitr,
     rmarkdown,
-    testthat (>= 3.0.0)
+    testthat (>= 3.0.0),
+    shinytest,
+    covr
 URL: https://github.com/agdamsbo/FreesearchR, https://agdamsbo.github.io/FreesearchR/
 BugReports: https://github.com/agdamsbo/FreesearchR/issues
 VignetteBuilder: knitr

NAMESPACE

@@ -5,12 +5,13 @@ S3method(cut_var,hms)
 S3method(plot,tbl_regression)
 export(add_class_icon)
 export(add_sparkline)
+export(align_axes)
 export(all_but)
-export(allign_axes)
 export(append_column)
 export(append_list)
 export(argsstring2list)
 export(baseline_table)
+export(class_icons)
 export(clean_common_axis)
 export(clean_date)
 export(clean_sep)
@@ -95,7 +96,6 @@ export(regression_model_uv_list)
 export(regression_table)
 export(remove_empty_attr)
 export(remove_empty_cols)
-export(remove_na_attr)
 export(remove_nested_list)
 export(repeated_instruments)
 export(sankey_ready)
@@ -108,6 +108,7 @@ export(supported_functions)
 export(supported_plots)
 export(symmetrical_scale_x_log10)
 export(tbl_merge)
+export(type_icons)
 export(update_factor_server)
 export(update_factor_ui)
 export(update_variables_server)
@@ -115,7 +116,6 @@ export(update_variables_ui)
 export(vectorSelectInput)
 export(vertical_stacked_bars)
 export(wide2long)
-export(winbox_cut_variable)
 export(winbox_update_factor)
 export(wrap_plot_list)
 export(write_quarto)

R/app_version.R

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

R/baseline_table.R

@@ -49,7 +49,7 @@ create_baseline <- function(data, ..., by.var, add.p = FALSE, add.overall = FALS
     }
   }
 
-  gtsummary::theme_gtsummary_journal(journal = theme)
+  suppressMessages(gtsummary::theme_gtsummary_journal(journal = theme))
 
   args <- list(...)
 

R/correlations-module.R

@@ -46,7 +46,8 @@ data_correlations_server <- function(id,
         } else {
           out <- data()
         }
-        out |> dplyr::mutate(dplyr::across(tidyselect::everything(),as.numeric))
+        # out |> dplyr::mutate(dplyr::across(tidyselect::everything(),as.numeric))
+        sapply(out,as.numeric)
         # as.numeric()
       })
 
@@ -100,8 +101,9 @@ data_correlations_server <- function(id,
 }
 
 correlation_pairs <- function(data, threshold = .8) {
-  data <- data[!sapply(data, is.character)]
+  data <- as.data.frame(data)[!sapply(as.data.frame(data), is.character)]
-  data <- data |> dplyr::mutate(dplyr::across(dplyr::where(is.factor), as.numeric))
+  data <- sapply(data,\(.x)if (is.factor(.x)) as.numeric(.x) else .x) |> as.data.frame()
+  # data <- data |> dplyr::mutate(dplyr::across(dplyr::where(is.factor), as.numeric))
   cor <- Hmisc::rcorr(as.matrix(data))
   r <- cor$r %>% as.table()
   d <- r |>

R/cut-variable-dates.R

@@ -18,7 +18,7 @@ cut_var <- function(x, ...) {
 #' @export
 #' @name cut_var
 cut_var.default <- function(x, ...) {
-  base::cut.default(x, ...)
+  base::cut(x, ...)
 }
 
 #' @name cut_var
@@ -581,36 +581,6 @@ modal_cut_variable <- function(id,
 }
 
 
-#' @inheritParams shinyWidgets::WinBox
-#' @export
-#'
-#' @importFrom shinyWidgets WinBox wbOptions wbControls
-#' @importFrom htmltools tagList
-#' @rdname cut-variable
-winbox_cut_variable <- function(id,
-                                title = i18n("Convert Numeric to Factor"),
-                                options = shinyWidgets::wbOptions(),
-                                controls = shinyWidgets::wbControls()) {
-  ns <- NS(id)
-  WinBox(
-    title = title,
-    ui = tagList(
-      cut_variable_ui(id),
-      tags$div(
-        style = "display: none;",
-        textInput(inputId = ns("hidden"), label = NULL, value = genId())
-      )
-    ),
-    options = modifyList(
-      shinyWidgets::wbOptions(height = "750px", modal = TRUE),
-      options
-    ),
-    controls = controls,
-    auto_height = FALSE
-  )
-}
-
-
 #' @importFrom graphics abline axis hist par plot.new plot.window
 plot_histogram <- function(data, column, bins = 30, breaks = NULL, color = "#112466") {
   x <- data[[column]]
@@ -627,3 +597,4 @@ plot_histogram <- function(data, column, bins = 30, breaks = NULL, color = "#112
   abline(v = breaks, col = "#FFFFFF", lty = 1, lwd = 1.5)
   abline(v = breaks, col = "#2E2E2E", lty = 2, lwd = 1.5)
 }
+

R/data-summary.R

@@ -155,8 +155,8 @@ overview_vars <- function(data) {
   data <- as.data.frame(data)
 
   dplyr::tibble(
-    class = get_classes(data),
+    icon = data_type(data),
-    type = data_type(data),
+    type = icon,
     name = names(data),
     n_missing = unname(colSums(is.na(data))),
     p_complete = 1 - n_missing / nrow(data),
@@ -188,7 +188,7 @@ create_overview_datagrid <- function(data,...) {
 
   std_names <- c(
     "Name" = "name",
-    "Class" = "class",
+    "Icon" = "icon",
     "Type" = "type",
     "Missings" = "n_missing",
     "Complete" = "p_complete",
@@ -226,7 +226,7 @@ create_overview_datagrid <- function(data,...) {
 
   grid <- toastui::grid_columns(
     grid = grid,
-    columns = "class",
+    columns = "icon",
     header = " ",
     align = "center",sortable = FALSE,
     width = 40
@@ -234,7 +234,8 @@ create_overview_datagrid <- function(data,...) {
 
   grid <- add_class_icon(
     grid = grid,
-    column = "class"
+    column = "icon",
+    fun = type_icons
   )
 
   grid <- toastui::grid_format(
@@ -271,14 +272,41 @@ create_overview_datagrid <- function(data,...) {
 #'   overview_vars() |>
 #'   toastui::datagrid() |>
 #'   add_class_icon()
-add_class_icon <- function(grid, column = "class") {
+add_class_icon <- function(grid, column = "class", fun=class_icons) {
   out <- toastui::grid_format(
     grid = grid,
     column = column,
     formatter = function(value) {
       lapply(
         X = value,
-        FUN = function(x) {
+        FUN = fun
+      )
+    }
+  )
+
+  toastui::grid_columns(
+    grid = out,
+    header = NULL,
+    columns = column,
+    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")) {
@@ -295,16 +323,39 @@ add_class_icon <- function(grid, column = "class") {
     shiny::icon("clock")
   } else {
     shiny::icon("table")
-          }
+  }}
-        }
+}
-      )
+
-    }
+#' Get data type icons
-  )
+#'
-
+#' @param x character vector of data classes
-  toastui::grid_columns(
+#'
-    grid = out,
+#' @returns list
-    header = NULL,
+#' @export
-    columns = column,
+#'
-    width = 60
+#' @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")
+    }
+    }
 }

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,29 +318,21 @@ data_visuals_server <- function(id,
 
       shiny::observeEvent(input$act_plot,
         {
-          if (NROW(data())>0){
+          if (NROW(data()) > 0) {
             tryCatch(
               {
                 parameters <- list(
                   type = rv$plot.params()[["fun"]],
-                x = input$primary,
+                  pri = input$primary,
-                y = input$secondary,
+                  sec = input$secondary,
-                z = input$tertiary
+                  ter = input$tertiary
                 )
 
                 shiny::withProgress(message = "Drawing the plot. Hold tight for a moment..", {
-                rv$plot <- rlang::exec(create_plot, !!!append_list(data(),parameters,"data"))
+                  rv$plot <- 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")
@@ -348,7 +340,8 @@ data_visuals_server <- function(id,
               error = function(err) {
                 showNotification(paste0(err), type = "err")
               }
-          )}
+            )
+          }
         },
         ignoreInit = TRUE
       )
@@ -415,7 +408,7 @@ all_but <- function(data, ...) {
 #'
 #' @examples
 #' default_parsing(mtcars) |> subset_types("ordinal")
-#' default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal" ,"categorical"))
+#' default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal", "categorical"))
 #' #' default_parsing(mtcars) |> subset_types("factor",class)
 subset_types <- function(data, types, type.fun = data_type) {
   data[sapply(data, type.fun) %in% types]
@@ -450,21 +443,21 @@ supported_plots <- function() {
       fun = "plot_hbars",
       descr = "Stacked horizontal bars",
       note = "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars",
-      primary.type = c("dichotomous", "ordinal" ,"categorical"),
+      primary.type = c("dichotomous", "ordinal", "categorical"),
-      secondary.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"),
+      primary.type = c("datatime", "continuous", "dichotomous", "ordinal", "categorical"),
-      secondary.type = c("dichotomous", "ordinal" ,"categorical"),
+      secondary.type = c("dichotomous", "ordinal", "categorical"),
       secondary.multi = FALSE,
       secondary.extra = "none",
-      tertiary.type = c("dichotomous", "ordinal" ,"categorical")
+      tertiary.type = c("dichotomous", "ordinal", "categorical")
     ),
     # plot_ridge = list(
     #   descr = "Ridge plot",
@@ -478,30 +471,30 @@ supported_plots <- function() {
       fun = "plot_sankey",
       descr = "Sankey plot",
       note = "A way of visualising change between groups",
-      primary.type = c("dichotomous", "ordinal" ,"categorical"),
+      primary.type = c("dichotomous", "ordinal", "categorical"),
-      secondary.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"),
+      primary.type = c("datatime", "continuous"),
-      secondary.type = c("datatime","continuous", "ordinal" ,"categorical"),
+      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"),
+      primary.type = c("datatime", "continuous", "dichotomous", "ordinal", "categorical"),
-      secondary.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_euler = list(
@@ -512,7 +505,7 @@ supported_plots <- function() {
       secondary.type = "dichotomous",
       secondary.multi = TRUE,
       secondary.max = 4,
-      tertiary.type = c("dichotomous", "ordinal" ,"categorical"),
+      tertiary.type = c("dichotomous", "ordinal", "categorical"),
       secondary.extra = NULL
     )
   )
@@ -591,9 +584,9 @@ get_plot_options <- function(data) {
 #' Wrapper to create plot based on provided type
 #'
 #' @param data data.frame
-#' @param x primary variable
+#' @param pri primary variable
-#' @param y secondary variable
+#' @param sec secondary variable
-#' @param z tertiary variable
+#' @param ter tertiary variable
 #' @param type plot type (derived from possible_plots() and matches custom function)
 #' @param ... ignored for now
 #'
@@ -603,20 +596,36 @@ get_plot_options <- function(data) {
 #' @export
 #'
 #' @examples
-#' create_plot(mtcars, "plot_violin", "mpg", "cyl")
+#' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes()
-create_plot <- function(data, type, x, y, z = NULL, ...) {
+create_plot <- function(data, type, pri, sec, ter = NULL, ...) {
-  if (!any(y %in% names(data))) {
+  if (!is.null(sec)) {
-    y <- NULL
+    if (!any(sec %in% names(data))) {
+      sec <- NULL
+    }
   }
 
-  if (!z %in% names(data)) {
+  if (!is.null(ter)) {
-    z <- NULL
+    if (!ter %in% names(data)) {
+      ter <- NULL
+    }
   }
 
-  do.call(
+  parameters <- list(
-    type,
+    pri = pri,
-    list(data, x, y, z, ...)
+    sec = sec,
+    ter = ter,
+    ...
   )
+
+  out <- do.call(
+    type,
+    modifyList(parameters,list(data=data))
+  )
+
+  code <- rlang::call2(type,!!!parameters,.ns = "FreesearchR")
+
+  attr(out,"code") <- code
+  out
 }
 
 #' Print label, and if missing print variable name
@@ -666,8 +675,8 @@ get_label <- function(data, var = NULL) {
 #'
 #' @examples
 #' "Lorem ipsum... you know the routine" |> line_break()
-#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(fixed = TRUE)
+#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE)
-line_break <- function(data, lineLength = 20, fixed = FALSE) {
+line_break <- function(data, lineLength = 20, force = FALSE) {
   if (isTRUE(force)) {
     gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), "\\1\n", data)
   } else {
@@ -698,7 +707,7 @@ wrap_plot_list <- function(data, tag_levels = NULL) {
             .x
           }
         })() |>
-        allign_axes() |>
+        align_axes() |>
         patchwork::wrap_plots(guides = "collect", axes = "collect", axis_titles = "collect")
       if (!is.null(tag_levels)) {
         out <- out + patchwork::plot_annotation(tag_levels = tag_levels)
@@ -713,19 +722,21 @@ wrap_plot_list <- function(data, tag_levels = NULL) {
 }
 
 
-#' Alligns axes between plots
+#' Aligns axes between plots
 #'
 #' @param ... ggplot2 objects or list of ggplot2 objects
 #'
 #' @returns list of ggplot2 objects
 #' @export
 #'
-allign_axes <- function(...) {
+align_axes <- function(...) {
   # https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object
   # https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150
   if (ggplot2::is.ggplot(..1)) {
+    ## Assumes list of ggplots
     p <- list(...)
   } else if (is.list(..1)) {
+    ## Assumes list with list of ggplots
     p <- ..1
   } else {
     cli::cli_abort("Can only align {.cls ggplot} objects or a list of them")

R/helpers.R

@@ -357,7 +357,7 @@ data_description <- function(data, data_text = "Data") {
   p_complete <- n_complete / n
 
   sprintf(
-    i18n("%s has %s observations and %s variables, with %s (%s%%) complete cases."),
+    "%s has %s observations and %s variables, with %s (%s%%) complete cases.",
     data_text,
     n,
     n_var,

R/plot_box.R

@@ -6,13 +6,13 @@
 #' @name data-plots
 #'
 #' @examples
-#' mtcars |> plot_box(x = "mpg", y = "cyl", z = "gear")
+#' mtcars |> plot_box(pri = "mpg", sec = "cyl", ter = "gear")
 #' mtcars |>
 #'   default_parsing() |>
-#'   plot_box(x = "mpg", y = "cyl", z = "gear")
+#'   plot_box(pri = "mpg", sec = "cyl", ter = "gear")
-plot_box <- function(data, x, y, z = NULL) {
+plot_box <- function(data, pri, sec, ter = NULL) {
-  if (!is.null(z)) {
+  if (!is.null(ter)) {
-    ds <- split(data, data[z])
+    ds <- split(data, data[ter])
   } else {
     ds <- list(data)
   }
@@ -20,13 +20,12 @@ plot_box <- function(data, x, y, z = NULL) {
   out <- lapply(ds, \(.ds){
     plot_box_single(
       data = .ds,
-      x = x,
+      pri = pri,
-      y = y
+      sec = sec
     )
   })
 
   wrap_plot_list(out)
-  # patchwork::wrap_plots(out,guides = "collect")
 }
 
 
@@ -41,18 +40,18 @@ plot_box <- function(data, x, y, z = NULL) {
 #'
 #' @examples
 #' mtcars |> plot_box_single("mpg","cyl")
-plot_box_single <- function(data, x, y=NULL, seed = 2103) {
+plot_box_single <- function(data, pri, sec=NULL, seed = 2103) {
   set.seed(seed)
 
-  if (is.null(y)) {
+  if (is.null(sec)) {
-    y <- "All"
+    sec <- "All"
-    data[[y]] <- y
+    data[[y]] <- sec
   }
 
-  discrete <- !data_type(data[[y]]) %in% "continuous"
+  discrete <- !data_type(data[[sec]]) %in% "continuous"
 
   data |>
-    ggplot2::ggplot(ggplot2::aes(x = !!dplyr::sym(x), y = !!dplyr::sym(y), fill = !!dplyr::sym(y), group = !!dplyr::sym(y))) +
+    ggplot2::ggplot(ggplot2::aes(x = !!dplyr::sym(pri), y = !!dplyr::sym(sec), fill = !!dplyr::sym(sec), group = !!dplyr::sym(sec))) +
     ggplot2::geom_boxplot(linewidth = 1.8, outliers = FALSE) +
     ## THis could be optional in future
     ggplot2::geom_jitter(color = "black", size = 2, alpha = 0.9, width = 0.1, height = .5) +

R/plot_euler.R

@@ -76,16 +76,16 @@ ggeulerr <- function(
 #'   D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE)
 #' ) |> plot_euler("A", c("B", "C"), "D", seed = 4)
 #' mtcars |> plot_euler("vs", "am", seed = 1)
-plot_euler <- function(data, x, y, z = NULL, seed = 2103) {
+plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) {
   set.seed(seed = seed)
-  if (!is.null(z)) {
+  if (!is.null(ter)) {
-    ds <- split(data, data[z])
+    ds <- split(data, data[ter])
   } else {
     ds <- list(data)
   }
 
   out <- lapply(ds, \(.x){
-    .x[c(x, y)] |>
+    .x[c(pri, sec)] |>
       as.data.frame() |>
       plot_euler_single()
   })
@@ -95,7 +95,6 @@ plot_euler <- function(data, x, y, z = NULL, seed = 2103) {
   # patchwork::wrap_plots(out, guides = "collect")
 }
 
-?withCallingHandlers()
 #' Easily plot single euler diagrams
 #'
 #' @returns ggplot2 object

R/plot_hbar.R

@@ -6,10 +6,10 @@
 #' @name data-plots
 #'
 #' @examples
-#' mtcars |> plot_hbars(x = "carb", y = "cyl")
+#' mtcars |> plot_hbars(pri = "carb", sec = "cyl")
-#' mtcars |> plot_hbars(x = "carb", y = NULL)
+#' mtcars |> plot_hbars(pri = "carb", sec = NULL)
-plot_hbars <- function(data, x, y, z = NULL) {
+plot_hbars <- function(data, pri, sec, ter = NULL) {
-  out <- vertical_stacked_bars(data = data, score = x, group = y, strata = z)
+  out <- vertical_stacked_bars(data = data, score = pri, group = sec, strata = ter)
 
   out
 }

R/plot_sankey.R

@@ -15,42 +15,42 @@
 #'   last = sample(c(TRUE, FALSE, FALSE), 100, TRUE)
 #' ) |>
 #'   sankey_ready("first", "last")
-sankey_ready <- function(data, x, y, numbers = "count", ...) {
+sankey_ready <- function(data, pri, sec, numbers = "count", ...) {
   ## TODO: Ensure ordering x and y
 
   ## Ensure all are factors
-  data[c(x, y)] <- data[c(x, y)] |>
+  data[c(pri, sec)] <- data[c(pri, sec)] |>
     dplyr::mutate(dplyr::across(!dplyr::where(is.factor), forcats::as_factor))
 
-  out <- dplyr::count(data, !!dplyr::sym(x), !!dplyr::sym(y))
+  out <- dplyr::count(data, !!dplyr::sym(pri), !!dplyr::sym(sec))
 
   out <- out |>
-    dplyr::group_by(!!dplyr::sym(x)) |>
+    dplyr::group_by(!!dplyr::sym(pri)) |>
     dplyr::mutate(gx.sum = sum(n)) |>
     dplyr::ungroup() |>
-    dplyr::group_by(!!dplyr::sym(y)) |>
+    dplyr::group_by(!!dplyr::sym(sec)) |>
     dplyr::mutate(gy.sum = sum(n)) |>
     dplyr::ungroup()
 
   if (numbers == "count") {
     out <- out |> dplyr::mutate(
-      lx = factor(paste0(!!dplyr::sym(x), "\n(n=", gx.sum, ")")),
+      lx = factor(paste0(!!dplyr::sym(pri), "\n(n=", gx.sum, ")")),
-      ly = factor(paste0(!!dplyr::sym(y), "\n(n=", gy.sum, ")"))
+      ly = factor(paste0(!!dplyr::sym(sec), "\n(n=", gy.sum, ")"))
     )
   } else if (numbers == "percentage") {
     out <- out |> dplyr::mutate(
-      lx = factor(paste0(!!dplyr::sym(x), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)")),
+      lx = factor(paste0(!!dplyr::sym(pri), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)")),
-      ly = factor(paste0(!!dplyr::sym(y), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)"))
+      ly = factor(paste0(!!dplyr::sym(sec), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)"))
     )
   }
 
-  if (is.factor(data[[x]])) {
+  if (is.factor(data[[pri]])) {
-    index <- match(levels(data[[x]]), str_remove_last(levels(out$lx), "\n"))
+    index <- match(levels(data[[pri]]), str_remove_last(levels(out$lx), "\n"))
     out$lx <- factor(out$lx, levels = levels(out$lx)[index])
   }
 
-  if (is.factor(data[[y]])) {
+  if (is.factor(data[[sec]])) {
-    index <- match(levels(data[[y]]), str_remove_last(levels(out$ly), "\n"))
+    index <- match(levels(data[[sec]]), str_remove_last(levels(out$ly), "\n"))
     out$ly <- factor(out$ly, levels = levels(out$ly)[index])
   }
 
@@ -75,15 +75,15 @@ str_remove_last <- function(data, pattern = "\n") {
 #' ds |> plot_sankey("first", "last")
 #' ds |> plot_sankey("first", "last", color.group = "y")
 #' ds |> plot_sankey("first", "last", z = "g", color.group = "y")
-plot_sankey <- function(data, x, y, z = NULL, color.group = "x", colors = NULL) {
+plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "x", colors = NULL) {
-  if (!is.null(z)) {
+  if (!is.null(ter)) {
-    ds <- split(data, data[z])
+    ds <- split(data, data[ter])
   } else {
     ds <- list(data)
   }
 
   out <- lapply(ds, \(.ds){
-    plot_sankey_single(.ds, x = x, y = y, color.group = color.group, colors = colors)
+    plot_sankey_single(.ds, x = pri, y = sec, color.group = color.group, colors = colors)
   })
 
   patchwork::wrap_plots(out)
@@ -112,10 +112,10 @@ default_theme <- function() {
 #'   first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)),
 #'   last = sample(c(TRUE, FALSE, FALSE), 100, TRUE)
 #' ) |>
-#'   plot_sankey_single("first", "last", color.group = "x")
+#'   plot_sankey_single("first", "last", color.group = "pri")
-plot_sankey_single <- function(data, x, y, color.group = c("x", "y"), colors = NULL, ...) {
+plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), colors = NULL, ...) {
   color.group <- match.arg(color.group)
-  data <- data |> sankey_ready(x = x, y = y, ...)
+  data <- data |> sankey_ready(pri = pri, sec = sec, ...)
 
   library(ggalluvial)
 
@@ -123,13 +123,13 @@ plot_sankey_single <- function(data, x, y, color.group = c("x", "y"), colors = N
   box.color <- "#1E4B66"
 
   if (is.null(colors)) {
-    if (color.group == "y") {
+    if (color.group == "sec") {
-      main.colors <- viridisLite::viridis(n = length(levels(data[[y]])))
+      main.colors <- viridisLite::viridis(n = length(levels(data[[sec]])))
-      secondary.colors <- rep(na.color, length(levels(data[[x]])))
+      secondary.colors <- rep(na.color, length(levels(data[[pri]])))
       label.colors <- Reduce(c, lapply(list(secondary.colors, rev(main.colors)), contrast_text))
     } else {
-      main.colors <- viridisLite::viridis(n = length(levels(data[[x]])))
+      main.colors <- viridisLite::viridis(n = length(levels(data[[pri]])))
-      secondary.colors <- rep(na.color, length(levels(data[[y]])))
+      secondary.colors <- rep(na.color, length(levels(data[[sec]])))
       label.colors <- Reduce(c, lapply(list(rev(main.colors), secondary.colors), contrast_text))
     }
     colors <- c(na.color, main.colors, secondary.colors)
@@ -137,33 +137,33 @@ plot_sankey_single <- function(data, x, y, color.group = c("x", "y"), colors = N
     label.colors <- contrast_text(colors)
   }
 
-  group_labels <- c(get_label(data, x), get_label(data, y)) |>
+  group_labels <- c(get_label(data, pri), get_label(data, sec)) |>
     sapply(line_break) |>
     unname()
 
   p <- ggplot2::ggplot(data, ggplot2::aes(y = n, axis1 = lx, axis2 = ly))
 
-  if (color.group == "y") {
+  if (color.group == "sec") {
     p <- p +
       ggalluvial::geom_alluvium(
-        ggplot2::aes(fill = !!dplyr::sym(y), color = !!dplyr::sym(y)),
+        ggplot2::aes(fill = !!dplyr::sym(sec), color = !!dplyr::sym(sec)),
         width = 1 / 16,
         alpha = .8,
         knot.pos = 0.4,
         curve_type = "sigmoid"
-      ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(y)),
+      ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(sec)),
         size = 2,
         width = 1 / 3.4
       )
   } else {
     p <- p +
       ggalluvial::geom_alluvium(
-        ggplot2::aes(fill = !!dplyr::sym(x), color = !!dplyr::sym(x)),
+        ggplot2::aes(fill = !!dplyr::sym(pri), color = !!dplyr::sym(pri)),
         width = 1 / 16,
         alpha = .8,
         knot.pos = 0.4,
         curve_type = "sigmoid"
-      ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(x)),
+      ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(pri)),
         size = 2,
         width = 1 / 3.4
       )

R/plot_scatter.R

@@ -6,20 +6,24 @@
 #' @name data-plots
 #'
 #' @examples
-#' mtcars |> plot_scatter(x = "mpg", y = "wt")
+#' mtcars |> plot_scatter(pri = "mpg", sec = "wt")
-plot_scatter <- function(data, x, y, z = NULL) {
+plot_scatter <- function(data, pri, sec, ter = NULL) {
-  if (is.null(z)) {
+  if (is.null(ter)) {
     rempsyc::nice_scatter(
       data = data,
-      predictor = y,
+      predictor = sec,
-      response = x, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x)
+      response = pri,
+      xtitle = get_label(data, var = sec),
+      ytitle = get_label(data, var = pri)
     )
   } else {
     rempsyc::nice_scatter(
       data = data,
-      predictor = y,
+      predictor = sec,
-      response = x,
+      response = pri,
-      group = z, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x)
+      group = ter,
+      xtitle = get_label(data, var = sec),
+      ytitle = get_label(data, var = pri)
     )
   }
 }

R/plot_violin.R

@@ -6,10 +6,10 @@
 #' @name data-plots
 #'
 #' @examples
-#' mtcars |> plot_violin(x = "mpg", y = "cyl", z = "gear")
+#' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear")
-plot_violin <- function(data, x, y, z = NULL) {
+plot_violin <- function(data, pri, sec, ter = NULL) {
-  if (!is.null(z)) {
+  if (!is.null(ter)) {
-    ds <- split(data, data[z])
+    ds <- split(data, data[ter])
   } else {
     ds <- list(data)
   }
@@ -17,8 +17,10 @@ plot_violin <- function(data, x, y, z = NULL) {
   out <- lapply(ds, \(.ds){
     rempsyc::nice_violin(
       data = .ds,
-      group = y,
+      group = sec,
-      response = x, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x)
+      response = pri,
+      xtitle = get_label(data, var = sec),
+      ytitle = get_label(data, var = pri)
     )
   })
 

inst/apps/FreesearchR/app.R

@@ -10,7 +10,7 @@
 #### Current file: /Users/au301842/FreesearchR/R//app_version.R 
 ########
 
-app_version <- function()'Version: 25.4.3.250414_1342'
+app_version <- function()'Version: 25.4.3.250415_1627'
 
 
 ########
@@ -68,7 +68,7 @@ create_baseline <- function(data, ..., by.var, add.p = FALSE, add.overall = FALS
     }
   }
 
-  gtsummary::theme_gtsummary_journal(journal = theme)
+  suppressMessages(gtsummary::theme_gtsummary_journal(journal = theme))
 
   args <- list(...)
 
@@ -207,7 +207,8 @@ data_correlations_server <- function(id,
         } else {
           out <- data()
         }
-        out |> dplyr::mutate(dplyr::across(tidyselect::everything(),as.numeric))
+        # out |> dplyr::mutate(dplyr::across(tidyselect::everything(),as.numeric))
+        sapply(out,as.numeric)
         # as.numeric()
       })
 
@@ -261,8 +262,9 @@ data_correlations_server <- function(id,
 }
 
 correlation_pairs <- function(data, threshold = .8) {
-  data <- data[!sapply(data, is.character)]
+  data <- as.data.frame(data)[!sapply(as.data.frame(data), is.character)]
-  data <- data |> dplyr::mutate(dplyr::across(dplyr::where(is.factor), as.numeric))
+  data <- sapply(data,\(.x)if (is.factor(.x)) as.numeric(.x) else .x) |> as.data.frame()
+  # data <- data |> dplyr::mutate(dplyr::across(dplyr::where(is.factor), as.numeric))
   cor <- Hmisc::rcorr(as.matrix(data))
   r <- cor$r %>% as.table()
   d <- r |>
@@ -516,7 +518,7 @@ cut_var <- function(x, ...) {
 #' @export
 #' @name cut_var
 cut_var.default <- function(x, ...) {
-  base::cut.default(x, ...)
+  base::cut(x, ...)
 }
 
 #' @name cut_var
@@ -1079,36 +1081,6 @@ modal_cut_variable <- function(id,
 }
 
 
-#' @inheritParams shinyWidgets::WinBox
-#' @export
-#'
-#' @importFrom shinyWidgets WinBox wbOptions wbControls
-#' @importFrom htmltools tagList
-#' @rdname cut-variable
-winbox_cut_variable <- function(id,
-                                title = i18n("Convert Numeric to Factor"),
-                                options = shinyWidgets::wbOptions(),
-                                controls = shinyWidgets::wbControls()) {
-  ns <- NS(id)
-  WinBox(
-    title = title,
-    ui = tagList(
-      cut_variable_ui(id),
-      tags$div(
-        style = "display: none;",
-        textInput(inputId = ns("hidden"), label = NULL, value = genId())
-      )
-    ),
-    options = modifyList(
-      shinyWidgets::wbOptions(height = "750px", modal = TRUE),
-      options
-    ),
-    controls = controls,
-    auto_height = FALSE
-  )
-}
-
-
 #' @importFrom graphics abline axis hist par plot.new plot.window
 plot_histogram <- function(data, column, bins = 30, breaks = NULL, color = "#112466") {
   x <- data[[column]]
@@ -1127,6 +1099,7 @@ plot_histogram <- function(data, column, bins = 30, breaks = NULL, color = "#112
 }
 
 
+
 ########
 #### Current file: /Users/au301842/FreesearchR/R//data_plots.R 
 ########
@@ -1221,7 +1194,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) {
     ),
     bslib::nav_panel(
       title = tab_title,
-      shiny::plotOutput(ns("plot"),height = "70vh"),
+      shiny::plotOutput(ns("plot"), height = "70vh"),
       shiny::tags$br(),
       shiny::tags$br(),
       shiny::htmlOutput(outputId = ns("code_plot"))
@@ -1248,7 +1221,7 @@ data_visuals_server <- function(id,
       rv <- shiny::reactiveValues(
         plot.params = NULL,
         plot = NULL,
-        code=NULL
+        code = NULL
       )
 
       # ## --- New attempt
@@ -1349,7 +1322,7 @@ data_visuals_server <- function(id,
         shiny::req(data())
         columnSelectInput(
           inputId = ns("primary"),
-          col_subset=names(data())[sapply(data(),data_type)!="text"],
+          col_subset = names(data())[sapply(data(), data_type) != "text"],
           data = data,
           placeholder = "Select variable",
           label = "Response variable",
@@ -1451,29 +1424,21 @@ data_visuals_server <- function(id,
 
       shiny::observeEvent(input$act_plot,
         {
-          if (NROW(data())>0){
+          if (NROW(data()) > 0) {
             tryCatch(
               {
                 parameters <- list(
                   type = rv$plot.params()[["fun"]],
-                x = input$primary,
+                  pri = input$primary,
-                y = input$secondary,
+                  sec = input$secondary,
-                z = input$tertiary
+                  ter = input$tertiary
                 )
 
                 shiny::withProgress(message = "Drawing the plot. Hold tight for a moment..", {
-                rv$plot <- rlang::exec(create_plot, !!!append_list(data(),parameters,"data"))
+                  rv$plot <- 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")
@@ -1481,7 +1446,8 @@ data_visuals_server <- function(id,
               error = function(err) {
                 showNotification(paste0(err), type = "err")
               }
-          )}
+            )
+          }
         },
         ignoreInit = TRUE
       )
@@ -1548,7 +1514,7 @@ all_but <- function(data, ...) {
 #'
 #' @examples
 #' default_parsing(mtcars) |> subset_types("ordinal")
-#' default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal" ,"categorical"))
+#' default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal", "categorical"))
 #' #' default_parsing(mtcars) |> subset_types("factor",class)
 subset_types <- function(data, types, type.fun = data_type) {
   data[sapply(data, type.fun) %in% types]
@@ -1583,21 +1549,21 @@ supported_plots <- function() {
       fun = "plot_hbars",
       descr = "Stacked horizontal bars",
       note = "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars",
-      primary.type = c("dichotomous", "ordinal" ,"categorical"),
+      primary.type = c("dichotomous", "ordinal", "categorical"),
-      secondary.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"),
+      primary.type = c("datatime", "continuous", "dichotomous", "ordinal", "categorical"),
-      secondary.type = c("dichotomous", "ordinal" ,"categorical"),
+      secondary.type = c("dichotomous", "ordinal", "categorical"),
       secondary.multi = FALSE,
       secondary.extra = "none",
-      tertiary.type = c("dichotomous", "ordinal" ,"categorical")
+      tertiary.type = c("dichotomous", "ordinal", "categorical")
     ),
     # plot_ridge = list(
     #   descr = "Ridge plot",
@@ -1611,30 +1577,30 @@ supported_plots <- function() {
       fun = "plot_sankey",
       descr = "Sankey plot",
       note = "A way of visualising change between groups",
-      primary.type = c("dichotomous", "ordinal" ,"categorical"),
+      primary.type = c("dichotomous", "ordinal", "categorical"),
-      secondary.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"),
+      primary.type = c("datatime", "continuous"),
-      secondary.type = c("datatime","continuous", "ordinal" ,"categorical"),
+      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"),
+      primary.type = c("datatime", "continuous", "dichotomous", "ordinal", "categorical"),
-      secondary.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_euler = list(
@@ -1645,7 +1611,7 @@ supported_plots <- function() {
       secondary.type = "dichotomous",
       secondary.multi = TRUE,
       secondary.max = 4,
-      tertiary.type = c("dichotomous", "ordinal" ,"categorical"),
+      tertiary.type = c("dichotomous", "ordinal", "categorical"),
       secondary.extra = NULL
     )
   )
@@ -1724,9 +1690,9 @@ get_plot_options <- function(data) {
 #' Wrapper to create plot based on provided type
 #'
 #' @param data data.frame
-#' @param x primary variable
+#' @param pri primary variable
-#' @param y secondary variable
+#' @param sec secondary variable
-#' @param z tertiary variable
+#' @param ter tertiary variable
 #' @param type plot type (derived from possible_plots() and matches custom function)
 #' @param ... ignored for now
 #'
@@ -1736,20 +1702,36 @@ get_plot_options <- function(data) {
 #' @export
 #'
 #' @examples
-#' create_plot(mtcars, "plot_violin", "mpg", "cyl")
+#' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes()
-create_plot <- function(data, type, x, y, z = NULL, ...) {
+create_plot <- function(data, type, pri, sec, ter = NULL, ...) {
-  if (!any(y %in% names(data))) {
+  if (!is.null(sec)) {
-    y <- NULL
+    if (!any(sec %in% names(data))) {
+      sec <- NULL
+    }
   }
 
-  if (!z %in% names(data)) {
+  if (!is.null(ter)) {
-    z <- NULL
+    if (!ter %in% names(data)) {
+      ter <- NULL
+    }
   }
 
-  do.call(
+  parameters <- list(
-    type,
+    pri = pri,
-    list(data, x, y, z, ...)
+    sec = sec,
+    ter = ter,
+    ...
   )
+
+  out <- do.call(
+    type,
+    modifyList(parameters,list(data=data))
+  )
+
+  code <- rlang::call2(type,!!!parameters,.ns = "FreesearchR")
+
+  attr(out,"code") <- code
+  out
 }
 
 #' Print label, and if missing print variable name
@@ -1799,8 +1781,8 @@ get_label <- function(data, var = NULL) {
 #'
 #' @examples
 #' "Lorem ipsum... you know the routine" |> line_break()
-#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(fixed = TRUE)
+#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE)
-line_break <- function(data, lineLength = 20, fixed = FALSE) {
+line_break <- function(data, lineLength = 20, force = FALSE) {
   if (isTRUE(force)) {
     gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), "\\1\n", data)
   } else {
@@ -1831,7 +1813,7 @@ wrap_plot_list <- function(data, tag_levels = NULL) {
             .x
           }
         })() |>
-        allign_axes() |>
+        align_axes() |>
         patchwork::wrap_plots(guides = "collect", axes = "collect", axis_titles = "collect")
       if (!is.null(tag_levels)) {
         out <- out + patchwork::plot_annotation(tag_levels = tag_levels)
@@ -1846,19 +1828,21 @@ wrap_plot_list <- function(data, tag_levels = NULL) {
 }
 
 
-#' Alligns axes between plots
+#' Aligns axes between plots
 #'
 #' @param ... ggplot2 objects or list of ggplot2 objects
 #'
 #' @returns list of ggplot2 objects
 #' @export
 #'
-allign_axes <- function(...) {
+align_axes <- function(...) {
   # https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object
   # https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150
   if (ggplot2::is.ggplot(..1)) {
+    ## Assumes list of ggplots
     p <- list(...)
   } else if (is.list(..1)) {
+    ## Assumes list with list of ggplots
     p <- ..1
   } else {
     cli::cli_abort("Can only align {.cls ggplot} objects or a list of them")
@@ -2213,8 +2197,8 @@ overview_vars <- function(data) {
   data <- as.data.frame(data)
 
   dplyr::tibble(
-    class = get_classes(data),
+    icon = data_type(data),
-    type = data_type(data),
+    type = icon,
     name = names(data),
     n_missing = unname(colSums(is.na(data))),
     p_complete = 1 - n_missing / nrow(data),
@@ -2246,7 +2230,7 @@ create_overview_datagrid <- function(data,...) {
 
   std_names <- c(
     "Name" = "name",
-    "Class" = "class",
+    "Icon" = "icon",
     "Type" = "type",
     "Missings" = "n_missing",
     "Complete" = "p_complete",
@@ -2284,7 +2268,7 @@ create_overview_datagrid <- function(data,...) {
 
   grid <- toastui::grid_columns(
     grid = grid,
-    columns = "class",
+    columns = "icon",
     header = " ",
     align = "center",sortable = FALSE,
     width = 40
@@ -2292,7 +2276,8 @@ create_overview_datagrid <- function(data,...) {
 
   grid <- add_class_icon(
     grid = grid,
-    column = "class"
+    column = "icon",
+    fun = type_icons
   )
 
   grid <- toastui::grid_format(
@@ -2329,14 +2314,41 @@ create_overview_datagrid <- function(data,...) {
 #'   overview_vars() |>
 #'   toastui::datagrid() |>
 #'   add_class_icon()
-add_class_icon <- function(grid, column = "class") {
+add_class_icon <- function(grid, column = "class", fun=class_icons) {
   out <- toastui::grid_format(
     grid = grid,
     column = column,
     formatter = function(value) {
       lapply(
         X = value,
-        FUN = function(x) {
+        FUN = fun
+      )
+    }
+  )
+
+  toastui::grid_columns(
+    grid = out,
+    header = NULL,
+    columns = column,
+    width = 60
+  )
+}
+
+
+#' 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")) {
@@ -2353,18 +2365,41 @@ add_class_icon <- function(grid, column = "class") {
     shiny::icon("clock")
   } else {
     shiny::icon("table")
-          }
+  }}
-        }
+}
-      )
-    }
-  )
 
-  toastui::grid_columns(
+#' Get data type icons
-    grid = out,
+#'
-    header = NULL,
+#' @param x character vector of data classes
-    columns = column,
+#'
-    width = 60
+#' @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")
+    }
+    }
 }
 
 
@@ -2731,7 +2766,7 @@ data_description <- function(data, data_text = "Data") {
   p_complete <- n_complete / n
 
   sprintf(
-    i18n("%s has %s observations and %s variables, with %s (%s%%) complete cases."),
+    "%s has %s observations and %s variables, with %s (%s%%) complete cases.",
     data_text,
     n,
     n_var,
@@ -3633,13 +3668,13 @@ launch_FreesearchR <- function(...){
 #' @name data-plots
 #'
 #' @examples
-#' mtcars |> plot_box(x = "mpg", y = "cyl", z = "gear")
+#' mtcars |> plot_box(pri = "mpg", sec = "cyl", ter = "gear")
 #' mtcars |>
 #'   default_parsing() |>
-#'   plot_box(x = "mpg", y = "cyl", z = "gear")
+#'   plot_box(pri = "mpg", sec = "cyl", ter = "gear")
-plot_box <- function(data, x, y, z = NULL) {
+plot_box <- function(data, pri, sec, ter = NULL) {
-  if (!is.null(z)) {
+  if (!is.null(ter)) {
-    ds <- split(data, data[z])
+    ds <- split(data, data[ter])
   } else {
     ds <- list(data)
   }
@@ -3647,13 +3682,12 @@ plot_box <- function(data, x, y, z = NULL) {
   out <- lapply(ds, \(.ds){
     plot_box_single(
       data = .ds,
-      x = x,
+      pri = pri,
-      y = y
+      sec = sec
     )
   })
 
   wrap_plot_list(out)
-  # patchwork::wrap_plots(out,guides = "collect")
 }
 
 
@@ -3668,18 +3702,18 @@ plot_box <- function(data, x, y, z = NULL) {
 #'
 #' @examples
 #' mtcars |> plot_box_single("mpg","cyl")
-plot_box_single <- function(data, x, y=NULL, seed = 2103) {
+plot_box_single <- function(data, pri, sec=NULL, seed = 2103) {
   set.seed(seed)
 
-  if (is.null(y)) {
+  if (is.null(sec)) {
-    y <- "All"
+    sec <- "All"
-    data[[y]] <- y
+    data[[y]] <- sec
   }
 
-  discrete <- !data_type(data[[y]]) %in% "continuous"
+  discrete <- !data_type(data[[sec]]) %in% "continuous"
 
   data |>
-    ggplot2::ggplot(ggplot2::aes(x = !!dplyr::sym(x), y = !!dplyr::sym(y), fill = !!dplyr::sym(y), group = !!dplyr::sym(y))) +
+    ggplot2::ggplot(ggplot2::aes(x = !!dplyr::sym(pri), y = !!dplyr::sym(sec), fill = !!dplyr::sym(sec), group = !!dplyr::sym(sec))) +
     ggplot2::geom_boxplot(linewidth = 1.8, outliers = FALSE) +
     ## THis could be optional in future
     ggplot2::geom_jitter(color = "black", size = 2, alpha = 0.9, width = 0.1, height = .5) +
@@ -3789,16 +3823,16 @@ ggeulerr <- function(
 #'   D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE)
 #' ) |> plot_euler("A", c("B", "C"), "D", seed = 4)
 #' mtcars |> plot_euler("vs", "am", seed = 1)
-plot_euler <- function(data, x, y, z = NULL, seed = 2103) {
+plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) {
   set.seed(seed = seed)
-  if (!is.null(z)) {
+  if (!is.null(ter)) {
-    ds <- split(data, data[z])
+    ds <- split(data, data[ter])
   } else {
     ds <- list(data)
   }
 
   out <- lapply(ds, \(.x){
-    .x[c(x, y)] |>
+    .x[c(pri, sec)] |>
       as.data.frame() |>
       plot_euler_single()
   })
@@ -3808,7 +3842,6 @@ plot_euler <- function(data, x, y, z = NULL, seed = 2103) {
   # patchwork::wrap_plots(out, guides = "collect")
 }
 
-?withCallingHandlers()
 #' Easily plot single euler diagrams
 #'
 #' @returns ggplot2 object
@@ -3854,10 +3887,10 @@ plot_euler_single <- function(data) {
 #' @name data-plots
 #'
 #' @examples
-#' mtcars |> plot_hbars(x = "carb", y = "cyl")
+#' mtcars |> plot_hbars(pri = "carb", sec = "cyl")
-#' mtcars |> plot_hbars(x = "carb", y = NULL)
+#' mtcars |> plot_hbars(pri = "carb", sec = NULL)
-plot_hbars <- function(data, x, y, z = NULL) {
+plot_hbars <- function(data, pri, sec, ter = NULL) {
-  out <- vertical_stacked_bars(data = data, score = x, group = y, strata = z)
+  out <- vertical_stacked_bars(data = data, score = pri, group = sec, strata = ter)
 
   out
 }
@@ -3998,42 +4031,42 @@ plot_ridge <- function(data, x, y, z = NULL, ...) {
 #'   last = sample(c(TRUE, FALSE, FALSE), 100, TRUE)
 #' ) |>
 #'   sankey_ready("first", "last")
-sankey_ready <- function(data, x, y, numbers = "count", ...) {
+sankey_ready <- function(data, pri, sec, numbers = "count", ...) {
   ## TODO: Ensure ordering x and y
 
   ## Ensure all are factors
-  data[c(x, y)] <- data[c(x, y)] |>
+  data[c(pri, sec)] <- data[c(pri, sec)] |>
     dplyr::mutate(dplyr::across(!dplyr::where(is.factor), forcats::as_factor))
 
-  out <- dplyr::count(data, !!dplyr::sym(x), !!dplyr::sym(y))
+  out <- dplyr::count(data, !!dplyr::sym(pri), !!dplyr::sym(sec))
 
   out <- out |>
-    dplyr::group_by(!!dplyr::sym(x)) |>
+    dplyr::group_by(!!dplyr::sym(pri)) |>
     dplyr::mutate(gx.sum = sum(n)) |>
     dplyr::ungroup() |>
-    dplyr::group_by(!!dplyr::sym(y)) |>
+    dplyr::group_by(!!dplyr::sym(sec)) |>
     dplyr::mutate(gy.sum = sum(n)) |>
     dplyr::ungroup()
 
   if (numbers == "count") {
     out <- out |> dplyr::mutate(
-      lx = factor(paste0(!!dplyr::sym(x), "\n(n=", gx.sum, ")")),
+      lx = factor(paste0(!!dplyr::sym(pri), "\n(n=", gx.sum, ")")),
-      ly = factor(paste0(!!dplyr::sym(y), "\n(n=", gy.sum, ")"))
+      ly = factor(paste0(!!dplyr::sym(sec), "\n(n=", gy.sum, ")"))
     )
   } else if (numbers == "percentage") {
     out <- out |> dplyr::mutate(
-      lx = factor(paste0(!!dplyr::sym(x), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)")),
+      lx = factor(paste0(!!dplyr::sym(pri), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)")),
-      ly = factor(paste0(!!dplyr::sym(y), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)"))
+      ly = factor(paste0(!!dplyr::sym(sec), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)"))
     )
   }
 
-  if (is.factor(data[[x]])) {
+  if (is.factor(data[[pri]])) {
-    index <- match(levels(data[[x]]), str_remove_last(levels(out$lx), "\n"))
+    index <- match(levels(data[[pri]]), str_remove_last(levels(out$lx), "\n"))
     out$lx <- factor(out$lx, levels = levels(out$lx)[index])
   }
 
-  if (is.factor(data[[y]])) {
+  if (is.factor(data[[sec]])) {
-    index <- match(levels(data[[y]]), str_remove_last(levels(out$ly), "\n"))
+    index <- match(levels(data[[sec]]), str_remove_last(levels(out$ly), "\n"))
     out$ly <- factor(out$ly, levels = levels(out$ly)[index])
   }
 
@@ -4058,15 +4091,15 @@ str_remove_last <- function(data, pattern = "\n") {
 #' ds |> plot_sankey("first", "last")
 #' ds |> plot_sankey("first", "last", color.group = "y")
 #' ds |> plot_sankey("first", "last", z = "g", color.group = "y")
-plot_sankey <- function(data, x, y, z = NULL, color.group = "x", colors = NULL) {
+plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "x", colors = NULL) {
-  if (!is.null(z)) {
+  if (!is.null(ter)) {
-    ds <- split(data, data[z])
+    ds <- split(data, data[ter])
   } else {
     ds <- list(data)
   }
 
   out <- lapply(ds, \(.ds){
-    plot_sankey_single(.ds, x = x, y = y, color.group = color.group, colors = colors)
+    plot_sankey_single(.ds, x = pri, y = sec, color.group = color.group, colors = colors)
   })
 
   patchwork::wrap_plots(out)
@@ -4095,10 +4128,10 @@ default_theme <- function() {
 #'   first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)),
 #'   last = sample(c(TRUE, FALSE, FALSE), 100, TRUE)
 #' ) |>
-#'   plot_sankey_single("first", "last", color.group = "x")
+#'   plot_sankey_single("first", "last", color.group = "pri")
-plot_sankey_single <- function(data, x, y, color.group = c("x", "y"), colors = NULL, ...) {
+plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), colors = NULL, ...) {
   color.group <- match.arg(color.group)
-  data <- data |> sankey_ready(x = x, y = y, ...)
+  data <- data |> sankey_ready(pri = pri, sec = sec, ...)
 
   library(ggalluvial)
 
@@ -4106,13 +4139,13 @@ plot_sankey_single <- function(data, x, y, color.group = c("x", "y"), colors = N
   box.color <- "#1E4B66"
 
   if (is.null(colors)) {
-    if (color.group == "y") {
+    if (color.group == "sec") {
-      main.colors <- viridisLite::viridis(n = length(levels(data[[y]])))
+      main.colors <- viridisLite::viridis(n = length(levels(data[[sec]])))
-      secondary.colors <- rep(na.color, length(levels(data[[x]])))
+      secondary.colors <- rep(na.color, length(levels(data[[pri]])))
       label.colors <- Reduce(c, lapply(list(secondary.colors, rev(main.colors)), contrast_text))
     } else {
-      main.colors <- viridisLite::viridis(n = length(levels(data[[x]])))
+      main.colors <- viridisLite::viridis(n = length(levels(data[[pri]])))
-      secondary.colors <- rep(na.color, length(levels(data[[y]])))
+      secondary.colors <- rep(na.color, length(levels(data[[sec]])))
       label.colors <- Reduce(c, lapply(list(rev(main.colors), secondary.colors), contrast_text))
     }
     colors <- c(na.color, main.colors, secondary.colors)
@@ -4120,33 +4153,33 @@ plot_sankey_single <- function(data, x, y, color.group = c("x", "y"), colors = N
     label.colors <- contrast_text(colors)
   }
 
-  group_labels <- c(get_label(data, x), get_label(data, y)) |>
+  group_labels <- c(get_label(data, pri), get_label(data, sec)) |>
     sapply(line_break) |>
     unname()
 
   p <- ggplot2::ggplot(data, ggplot2::aes(y = n, axis1 = lx, axis2 = ly))
 
-  if (color.group == "y") {
+  if (color.group == "sec") {
     p <- p +
       ggalluvial::geom_alluvium(
-        ggplot2::aes(fill = !!dplyr::sym(y), color = !!dplyr::sym(y)),
+        ggplot2::aes(fill = !!dplyr::sym(sec), color = !!dplyr::sym(sec)),
         width = 1 / 16,
         alpha = .8,
         knot.pos = 0.4,
         curve_type = "sigmoid"
-      ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(y)),
+      ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(sec)),
         size = 2,
         width = 1 / 3.4
       )
   } else {
     p <- p +
       ggalluvial::geom_alluvium(
-        ggplot2::aes(fill = !!dplyr::sym(x), color = !!dplyr::sym(x)),
+        ggplot2::aes(fill = !!dplyr::sym(pri), color = !!dplyr::sym(pri)),
         width = 1 / 16,
         alpha = .8,
         knot.pos = 0.4,
         curve_type = "sigmoid"
-      ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(x)),
+      ) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(pri)),
         size = 2,
         width = 1 / 3.4
       )
@@ -4195,20 +4228,24 @@ plot_sankey_single <- function(data, x, y, color.group = c("x", "y"), colors = N
 #' @name data-plots
 #'
 #' @examples
-#' mtcars |> plot_scatter(x = "mpg", y = "wt")
+#' mtcars |> plot_scatter(pri = "mpg", sec = "wt")
-plot_scatter <- function(data, x, y, z = NULL) {
+plot_scatter <- function(data, pri, sec, ter = NULL) {
-  if (is.null(z)) {
+  if (is.null(ter)) {
     rempsyc::nice_scatter(
       data = data,
-      predictor = y,
+      predictor = sec,
-      response = x, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x)
+      response = pri,
+      xtitle = get_label(data, var = sec),
+      ytitle = get_label(data, var = pri)
     )
   } else {
     rempsyc::nice_scatter(
       data = data,
-      predictor = y,
+      predictor = sec,
-      response = x,
+      response = pri,
-      group = z, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x)
+      group = ter,
+      xtitle = get_label(data, var = sec),
+      ytitle = get_label(data, var = pri)
     )
   }
 }
@@ -4226,10 +4263,10 @@ plot_scatter <- function(data, x, y, z = NULL) {
 #' @name data-plots
 #'
 #' @examples
-#' mtcars |> plot_violin(x = "mpg", y = "cyl", z = "gear")
+#' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear")
-plot_violin <- function(data, x, y, z = NULL) {
+plot_violin <- function(data, pri, sec, ter = NULL) {
-  if (!is.null(z)) {
+  if (!is.null(ter)) {
-    ds <- split(data, data[z])
+    ds <- split(data, data[ter])
   } else {
     ds <- list(data)
   }
@@ -4237,8 +4274,10 @@ plot_violin <- function(data, x, y, z = NULL) {
   out <- lapply(ds, \(.ds){
     rempsyc::nice_violin(
       data = .ds,
-      group = y,
+      group = sec,
-      response = x, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x)
+      response = pri,
+      xtitle = get_label(data, var = sec),
+      ytitle = get_label(data, var = pri)
     )
   })
 

inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf

@@ -5,6 +5,6 @@ account: agdamsbo
 server: shinyapps.io
 hostUrl: https://api.shinyapps.io/v1
 appId: 13611288
-bundleId: 10111887
+bundleId: 10119038
 url: https://agdamsbo.shinyapps.io/freesearcheR/
 version: 1

man/add_class_icon.Rd

@@ -4,7 +4,7 @@
 \alias{add_class_icon}
 \title{Convert class grid column to icon}
 \usage{
-add_class_icon(grid, column = "class")
+add_class_icon(grid, column = "class", fun = class_icons)
 }
 \arguments{
 \item{grid}{grid}

man/align_axes.Rd

@@ -1,10 +1,10 @@
 % Generated by roxygen2: do not edit by hand
 % Please edit documentation in R/data_plots.R
-\name{allign_axes}
+\name{align_axes}
-\alias{allign_axes}
+\alias{align_axes}
-\title{Alligns axes between plots}
+\title{Aligns axes between plots}
 \usage{
-allign_axes(...)
+align_axes(...)
 }
 \arguments{
 \item{...}{ggplot2 objects or list of ggplot2 objects}
@@ -13,5 +13,5 @@ allign_axes(...)
 list of ggplot2 objects
 }
 \description{
-Alligns axes between plots
+Aligns axes between plots
 }

man/argsstring2list.Rd

@@ -15,3 +15,7 @@ list
 \description{
 Idea from the answer: https://stackoverflow.com/a/62979238
 }
+\examples{
+argsstring2list("A=1:5,b=2:4")
+
+}

man/class_icons.Rd

@@ -0,0 +1,21 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/data-summary.R
+\name{class_icons}
+\alias{class_icons}
+\title{Get data class icons}
+\usage{
+class_icons(x)
+}
+\arguments{
+\item{x}{character vector of data classes}
+}
+\value{
+list
+}
+\description{
+Get data class icons
+}
+\examples{
+"numeric" |> class_icons()|> str()
+mtcars |> sapply(class) |> class_icons() |> str()
+}

man/create_baseline.Rd

@@ -32,4 +32,5 @@ Create a baseline table
 }
 \examples{
 mtcars |> create_baseline(by.var = "gear", add.p = "yes" == "yes")
+create_baseline(default_parsing(mtcars), by.var = "am", add.p = FALSE, add.overall = FALSE, theme = "lancet")
 }

man/cut-variable.Rd

@@ -5,7 +5,6 @@
 \alias{cut_variable_ui}
 \alias{cut_variable_server}
 \alias{modal_cut_variable}
-\alias{winbox_cut_variable}
 \title{Module to Convert Numeric to Factor}
 \usage{
 cut_variable_ui(id)
@@ -19,13 +18,6 @@ modal_cut_variable(
   size = "l",
   footer = NULL
 )
-
-winbox_cut_variable(
-  id,
-  title = i18n("Convert Numeric to Factor"),
-  options = shinyWidgets::wbOptions(),
-  controls = shinyWidgets::wbControls()
-)
 }
 \arguments{
 \item{id}{Module ID.}
@@ -47,10 +39,6 @@ pass \code{\link[bslib:bs_theme]{bslib::bs_theme()}} to the \code{theme} argumen
 like \code{\link[shiny:fluidPage]{fluidPage()}}).}
 
 \item{footer}{UI for footer. Use \code{NULL} for no footer.}
-
-\item{options}{List of options, see \code{\link[shinyWidgets:wbOptions]{wbOptions()}}.}
-
-\item{controls}{List of controls, see \code{\link[shinyWidgets:wbControls]{wbControls()}}.}
 }
 \value{
 A \code{\link[shiny:reactive]{shiny::reactive()}} function returning the data.

man/data-plots.Rd

@@ -20,23 +20,23 @@ data_visuals_ui(id, tab_title = "Plots", ...)
 
 data_visuals_server(id, data, ...)
 
-create_plot(data, type, x, y, z = NULL, ...)
+create_plot(data, type, pri, sec, ter = NULL, ...)
 
-plot_box(data, x, y, z = NULL)
+plot_box(data, pri, sec, ter = NULL)
 
-plot_box_single(data, x, y = NULL, seed = 2103)
+plot_box_single(data, pri, sec = NULL, seed = 2103)
 
-plot_hbars(data, x, y, z = NULL)
+plot_hbars(data, pri, sec, ter = NULL)
 
 plot_ridge(data, x, y, z = NULL, ...)
 
-sankey_ready(data, x, y, numbers = "count", ...)
+sankey_ready(data, pri, sec, numbers = "count", ...)
 
-plot_sankey(data, x, y, z = NULL, color.group = "x", colors = NULL)
+plot_sankey(data, pri, sec, ter = NULL, color.group = "x", colors = NULL)
 
-plot_scatter(data, x, y, z = NULL)
+plot_scatter(data, pri, sec, ter = NULL)
 
-plot_violin(data, x, y, z = NULL)
+plot_violin(data, pri, sec, ter = NULL)
 }
 \arguments{
 \item{id}{Module id. (Use 'ns("id")')}
@@ -47,11 +47,11 @@ plot_violin(data, x, y, z = NULL)
 
 \item{type}{plot type (derived from possible_plots() and matches custom function)}
 
-\item{x}{primary variable}
+\item{pri}{primary variable}
 
-\item{y}{secondary variable}
+\item{sec}{secondary variable}
 
-\item{z}{tertiary variable}
+\item{ter}{tertiary variable}
 }
 \value{
 Shiny ui module
@@ -98,14 +98,14 @@ Beautiful violin plot
 Beatiful violin plot
 }
 \examples{
-create_plot(mtcars, "plot_violin", "mpg", "cyl")
+create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes()
-mtcars |> plot_box(x = "mpg", y = "cyl", z = "gear")
+mtcars |> plot_box(pri = "mpg", sec = "cyl", ter = "gear")
 mtcars |>
   default_parsing() |>
-  plot_box(x = "mpg", y = "cyl", z = "gear")
+  plot_box(pri = "mpg", sec = "cyl", ter = "gear")
 mtcars |> plot_box_single("mpg","cyl")
-mtcars |> plot_hbars(x = "carb", y = "cyl")
+mtcars |> plot_hbars(pri = "carb", sec = "cyl")
-mtcars |> plot_hbars(x = "carb", y = NULL)
+mtcars |> plot_hbars(pri = "carb", sec = NULL)
 mtcars |>
   default_parsing() |>
   plot_ridge(x = "mpg", y = "cyl")
@@ -123,6 +123,6 @@ ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_fac
 ds |> plot_sankey("first", "last")
 ds |> plot_sankey("first", "last", color.group = "y")
 ds |> plot_sankey("first", "last", z = "g", color.group = "y")
-mtcars |> plot_scatter(x = "mpg", y = "wt")
+mtcars |> plot_scatter(pri = "mpg", sec = "wt")
-mtcars |> plot_violin(x = "mpg", y = "cyl", z = "gear")
+mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear")
 }

man/data_type_filter.Rd

@@ -18,8 +18,13 @@ data.frame
 Filter function to filter data set by variable type
 }
 \examples{
-default_parsing(mtcars) |> data_type_filter(type=c("categorical","continuous")) |> attributes()
+default_parsing(mtcars) |>
+  data_type_filter(type = c("categorical", "continuous")) |>
+  attributes()
+default_parsing(mtcars) |>
+  data_type_filter(type = NULL) |>
+  attributes()
 \dontrun{
-default_parsing(mtcars) |> data_type_filter(type=c("test","categorical","continuous"))
+default_parsing(mtcars) |> data_type_filter(type = c("test", "categorical", "continuous"))
 }
 }

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

man/factorize.Rd

@@ -17,3 +17,6 @@ data.frame
 \description{
 Factorize variables in data.frame
 }
+\examples{
+factorize(mtcars,names(mtcars))
+}

man/line_break.Rd

@@ -4,7 +4,7 @@
 \alias{line_break}
 \title{Line breaking at given number of characters for nicely plotting labels}
 \usage{
-line_break(data, lineLength = 20, fixed = FALSE)
+line_break(data, lineLength = 20, force = FALSE)
 }
 \arguments{
 \item{data}{string}
@@ -22,5 +22,5 @@ Line breaking at given number of characters for nicely plotting labels
 }
 \examples{
 "Lorem ipsum... you know the routine" |> line_break()
-paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(fixed = TRUE)
+paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE)
 }

man/plot_euler.Rd

@@ -4,18 +4,18 @@
 \alias{plot_euler}
 \title{Easily plot euler diagrams}
 \usage{
-plot_euler(data, x, y, z = NULL, seed = 2103)
+plot_euler(data, pri, sec, ter = NULL, seed = 2103)
 }
 \arguments{
 \item{data}{data}
 
+\item{seed}{seed}
+
 \item{x}{name of main variable}
 
 \item{y}{name of secondary variables}
 
 \item{z}{grouping variable}
-
-\item{seed}{seed}
 }
 \value{
 patchwork object

man/plot_sankey_single.Rd

@@ -4,7 +4,14 @@
 \alias{plot_sankey_single}
 \title{Beautiful sankey plot}
 \usage{
-plot_sankey_single(data, x, y, color.group = c("x", "y"), colors = NULL, ...)
+plot_sankey_single(
+  data,
+  pri,
+  sec,
+  color.group = c("pri", "sec"),
+  colors = NULL,
+  ...
+)
 }
 \arguments{
 \item{color.group}{set group to colour by. "x" or "y".}
@@ -29,5 +36,5 @@ data.frame(
   first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)),
   last = sample(c(TRUE, FALSE, FALSE), 100, TRUE)
 ) |>
-  plot_sankey_single("first", "last", color.group = "x")
+  plot_sankey_single("first", "last", color.group = "pri")
 }

man/remove_empty_attr.Rd

@@ -15,3 +15,12 @@ data of same class as input
 \description{
 Remove empty/NA attributes
 }
+\examples{
+ds <- mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x, label = NA, attr = "label")) |> dplyr::bind_cols()
+ds |>
+  remove_empty_attr() |>
+  str()
+ mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x, label = NA, attr = "label")) |> remove_empty_attr() |>
+  str()
+
+}

man/remove_na_attr.Rd

@@ -1,23 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/helpers.R
-\name{remove_na_attr}
-\alias{remove_na_attr}
-\title{Remove NA labels}
-\usage{
-remove_na_attr(data, attr = "label")
-}
-\arguments{
-\item{data}{data}
-}
-\value{
-data.frame
-}
-\description{
-Remove NA labels
-}
-\examples{
-ds <- mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x, label = NA, attr = "label"))
-ds |>
-  remove_na_attr() |>
-  str()
-}

man/remove_nested_list.Rd

@@ -2,7 +2,7 @@
 % Please edit documentation in R/helpers.R
 \name{remove_nested_list}
 \alias{remove_nested_list}
-\title{Very simple function to remove nested lists, lik ewhen uploading .rds}
+\title{Very simple function to remove nested lists, like when uploading .rds}
 \usage{
 remove_nested_list(data)
 }
@@ -13,7 +13,7 @@ remove_nested_list(data)
 data.frame
 }
 \description{
-Very simple function to remove nested lists, lik ewhen uploading .rds
+Very simple function to remove nested lists, like when uploading .rds
 }
 \examples{
 dplyr::tibble(a = 1:10, b = rep(list("a"), 10)) |> remove_nested_list()

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

man/type_icons.Rd

@@ -0,0 +1,21 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/data-summary.R
+\name{type_icons}
+\alias{type_icons}
+\title{Get data type icons}
+\usage{
+type_icons(x)
+}
+\arguments{
+\item{x}{character vector of data classes}
+}
+\value{
+list
+}
+\description{
+Get data type icons
+}
+\examples{
+"ordinal" |> type_icons()
+default_parsing(mtcars) |> sapply(data_type) |> type_icons()
+}

tests/testthat.R

@@ -8,5 +8,6 @@
 
 library(testthat)
 library(FreesearchR)
+library(shiny)
 
 test_check("FreesearchR")

tests/testthat/_snaps/contrast_text.md

@@ -0,0 +1,23 @@
+# Contrasting works
+
+    Code
+      contrast_text(colors)
+    Output
+      [1] "black" "white" "white" "white" "black" "white"
+
+---
+
+    Code
+      contrast_text(colors, light_text = "blue", dark_text = "grey10", method = "relative",
+        threshold = 0.1)
+    Output
+      [1] "grey10" "blue"   "grey10" "blue"   "grey10" "grey10"
+
+---
+
+    Code
+      contrast_text(colors, light_text = "blue", dark_text = "grey10", method = "perceived",
+        threshold = 0.7)
+    Output
+      [1] "grey10" "blue"   "blue"   "blue"   "grey10" "blue"  
+

tests/testthat/_snaps/data_plots.md

@@ -0,0 +1,160 @@
+# all_but works
+
+    Code
+      all_but(1:10, c(2, 3), 11, 5)
+    Output
+      [1]  1  4  6  7  8  9 10
+
+# subset_types works
+
+    Code
+      subset_types(default_parsing(mtcars), "continuous")
+    Output
+      # A tibble: 32 x 6
+           mpg  disp    hp  drat    wt  qsec
+         <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
+       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 
+         <fct> <lgl> <lgl> <fct> <fct>
+       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"
+

tests/testthat/_snaps/helpers.md

@@ -0,0 +1,532 @@
+# getfun works
+
+    Code
+      getfun("stats::lm")
+    Output
+      function (formula, data, subset, weights, na.action, method = "qr", 
+          model = TRUE, x = FALSE, y = FALSE, qr = TRUE, singular.ok = TRUE, 
+          contrasts = NULL, offset, ...) 
+      {
+          ret.x <- x
+          ret.y <- y
+          cl <- match.call()
+          mf <- match.call(expand.dots = FALSE)
+          m <- match(c("formula", "data", "subset", "weights", "na.action", 
+              "offset"), names(mf), 0L)
+          mf <- mf[c(1L, m)]
+          mf$drop.unused.levels <- TRUE
+          mf[[1L]] <- quote(stats::model.frame)
+          mf <- eval(mf, parent.frame())
+          if (method == "model.frame") 
+              return(mf)
+          else if (method != "qr") 
+              warning(gettextf("method = '%s' is not supported. Using 'qr'", 
+                  method), domain = NA)
+          mt <- attr(mf, "terms")
+          y <- model.response(mf, "numeric")
+          w <- as.vector(model.weights(mf))
+          if (!is.null(w) && !is.numeric(w)) 
+              stop("'weights' must be a numeric vector")
+          offset <- model.offset(mf)
+          mlm <- is.matrix(y)
+          ny <- if (mlm) 
+              nrow(y)
+          else length(y)
+          if (!is.null(offset)) {
+              if (!mlm) 
+                  offset <- as.vector(offset)
+              if (NROW(offset) != ny) 
+                  stop(gettextf("number of offsets is %d, should equal %d (number of observations)", 
+                      NROW(offset), ny), domain = NA)
+          }
+          if (is.empty.model(mt)) {
+              x <- NULL
+              z <- list(coefficients = if (mlm) matrix(NA_real_, 0, 
+                  ncol(y)) else numeric(), residuals = y, fitted.values = 0 * 
+                  y, weights = w, rank = 0L, df.residual = if (!is.null(w)) sum(w != 
+                  0) else ny)
+              if (!is.null(offset)) {
+                  z$fitted.values <- offset
+                  z$residuals <- y - offset
+              }
+          }
+          else {
+              x <- model.matrix(mt, mf, contrasts)
+              z <- if (is.null(w)) 
+                  lm.fit(x, y, offset = offset, singular.ok = singular.ok, 
+                      ...)
+              else lm.wfit(x, y, w, offset = offset, singular.ok = singular.ok, 
+                  ...)
+          }
+          class(z) <- c(if (mlm) "mlm", "lm")
+          z$na.action <- attr(mf, "na.action")
+          z$offset <- offset
+          z$contrasts <- attr(x, "contrasts")
+          z$xlevels <- .getXlevels(mt, mf)
+          z$call <- cl
+          z$terms <- mt
+          if (model) 
+              z$model <- mf
+          if (ret.x) 
+              z$x <- x
+          if (ret.y) 
+              z$y <- y
+          if (!qr) 
+              z$qr <- NULL
+          z
+      }
+      <bytecode: 0x12c7f2dd8>
+      <environment: namespace:stats>
+
+# 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 
+         <dbl> <fct> <dbl> <dbl> <dbl> <dbl> <dbl> <lgl> <lgl> <fct> <fct>
+       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
+         <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
+       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 
+         <dbl> <fct> <dbl> <dbl> <dbl> <dbl> <dbl> <fct> <fct>
+       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 
+         <dbl> <fct> <dbl> <dbl> <dbl> <dbl> <dbl> <lgl> <lgl> <fct> <fct>
+       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
+         <int>
+       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
+         <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
+       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
+

tests/testthat/test-baseline_table.R

@@ -3,44 +3,26 @@
 
 test_that("Creates correct table",{
   ## This is by far the easiest way to test all functions. Based on examples.
-  expect_snapshot(create_baseline(mtcars,by.var = "gear", add.p = "yes" == "yes",add.overall = TRUE, theme = "lancet"))
+  tbl <- 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", {
+  expect_equal(length(tbl),5)
-  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"))
-})

tests/testthat/test-correlations-module.R

@@ -0,0 +1,17 @@
+test_that("correlations module works", {
+  testServer(data_correlations_server, args=list(data = mtcars,cutoff = shiny::reactive(.8)), {
+    expect_equal(nchar(output$suggest), 281)
+    expect_equal(class(output$correlation_plot),"list")
+    expect_equal(length(output$correlation_plot),5)
+  })
+
+  expect_snapshot(
+    correlation_pairs(data = gtsummary::trial,threshold = .2)
+    )
+
+  expect_snapshot(
+  sentence_paste(letters[1:8])
+  )
+
+})
+

tests/testthat/test-custom_SelectInput.R

@@ -1,3 +1,83 @@
 test_that("Create columnSelectInput", {
-  expect_snapshot(columnSelectInput("x",label = "X",data = mtcars))
+  library(shiny)
+  ui <- shiny::fluidPage(
+    shiny::uiOutput("x"),
+    shiny::uiOutput("out")
+  )
+  server <- function(input, output, session) {
+    library(FreesearchR)
+    output$x <-
+      shiny::renderUI({
+      columnSelectInput(inputId = "x",selected = "mpg",label = "X",data = mtcars)
+      })
+
+    output$out <- renderText({
+      # req(input$x)
+      input$x
+      })
+  }
+
+  # shinyApp(ui,server)
+
+  testServer(server, {
+    session$setInputs(x = "cyl")
+    expect_equal(output$out, "cyl")
+
+    session$setInputs(x = "mpg")
+    expect_equal(output$out, "mpg")
+  })
+
+  server <- function(input, output, session) {
+    library(FreesearchR)
+    output$x <-
+      shiny::renderUI({
+        columnSelectInput(inputId = "x",label = "X",data = gtsummary::trial)
+      })
+
+    output$out <- renderText({
+      # req(input$x)
+      input$x
+    })
+  }
+
+  # shinyApp(ui,server)
+
+  testServer(server, {
+    session$setInputs(x = "trt")
+    expect_equal(output$out, "trt")
+
+    session$setInputs(x = "stage")
+    expect_equal(output$out, "stage")
+  })
+
+})
+
+test_that("Create columnSelectInput", {
+  library(shiny)
+  ui <- shiny::fluidPage(
+    shiny::uiOutput("x"),
+    shiny::uiOutput("out")
+  )
+  server <- function(input, output, session) {
+    library(FreesearchR)
+    output$x <-
+      shiny::renderUI({
+        vectorSelectInput(inputId = "x",choices = setNames(names(mtcars),seq_len(ncol(mtcars))),label = "X")
+      })
+
+    output$out <- renderText({
+      # req(input$x)
+      input$x
+    })
+  }
+
+  # shinyApp(ui,server)
+
+  testServer(server, {
+    session$setInputs(x = "cyl")
+    expect_equal(output$out, "cyl")
+
+    session$setInputs(x = "mpg")
+    expect_equal(output$out, "mpg")
+  })
 })

tests/testthat/test-cut-variable-dates.R

@@ -0,0 +1,47 @@
+test_that("datetime cutting works", {
+  ## HMS
+  data <- readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20"))
+
+  breaks <- list(2, "min", "hour", hms::as_hms(c("01:00:00", "03:01:20", "9:20:20")))
+
+  lapply(breaks, \(.x){
+    cut_var(x = data, breaks = .x)
+  }) |> expect_snapshot()
+
+
+  data <- readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "03:02:20", NA))
+
+  lapply(breaks, \(.x){
+    cut_var(x = data, breaks = .x)
+  }) |> expect_snapshot()
+
+  expect_snapshot(
+    readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "03:02:20", NA)) |> cut_var(breaks = lubridate::as_datetime(c(hms::as_hms(levels(cut_var(data, 2))), hms::as_hms(max(data, na.rm = TRUE) + 1))), right = FALSE)
+  )
+
+  ## DATETIME
+
+  data <- readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20"))
+
+  breaks <- list(list(breaks = 2), list(breaks = "weekday"), list(breaks = "month_only"), list(breaks = NULL, format = "%A-%H"))
+
+  lapply(breaks, \(.x){
+    do.call(cut_var, modifyList(.x, list(x = data)))
+  }) |> expect_snapshot()
+})
+
+## is_any_class
+test_that("is_any_class works", {
+  expect_snapshot(
+    vapply(REDCapCAST::redcapcast_data, \(.x){
+    is_any_class(.x, c("hms", "Date", "POSIXct", "POSIXt"))
+  }, logical(1))
+  )
+
+  expect_snapshot(
+  vapply(REDCapCAST::redcapcast_data, is_datetime, logical(1))
+
+  )
+
+})
+

tests/testthat/test-data_plots.R

@@ -0,0 +1,85 @@
+## all_but
+test_that("all_but works", {
+  expect_snapshot(all_but(1:10, c(2, 3), 11, 5))
+})
+
+## subset_types
+test_that("subset_types works", {
+  expect_snapshot(
+    default_parsing(mtcars) |> subset_types("continuous")
+  )
+  expect_snapshot(
+    default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal", "categorical"))
+  )
+  expect_snapshot(
+    default_parsing(mtcars) |> subset_types("test")
+  )
+})
+
+## supported_plots
+test_that("supported_plots works", {
+  expect_true(is.list(supported_plots()))
+})
+
+## possible_plots
+test_that("possible_plots works", {
+  expect_snapshot(possible_plots(mtcars$mpg))
+
+  expect_snapshot(default_parsing(mtcars)["cyl"] |>
+    possible_plots())
+})
+
+## get_plot_options
+test_that("get_plot_options works", {
+  expect_snapshot(default_parsing(mtcars)["mpg"] |>
+    possible_plots() |>
+    (\(.x){
+      .x[[1]]
+    })() |>
+    get_plot_options())
+})
+
+## create_plot and friends
+test_that("create_plot works", {
+  ## Violin
+  p_list <- create_plot(mtcars, type = "plot_violin", pri = "mpg", sec = "cyl", ter = "am")
+  p <- p_list[[1]] + ggplot2::labs(title = "Test plot")
+
+  expect_equal(length(p_list), 2)
+  expect_true(ggplot2::is.ggplot(p))
+
+  # Includes helper functions
+  #   wrap_plot_list
+  #   align_axes
+  #   clean_common_axis
+
+  ## Scatter
+  p_list <- list(
+    create_plot(mtcars, type = "plot_scatter", pri = "mpg", sec = "cyl"),
+    create_plot(mtcars, type = "plot_scatter", pri = "mpg", sec = "cyl", ter = "am")
+  )
+
+  lapply(p_list, \(.x){
+    expect_true(ggplot2::is.ggplot(.x))
+  })
+
+  purrr::map2(p_list, list(11, 11), \(.x, .y){
+    expect_equal(length(.x), .y)
+  })
+})
+
+## get_label
+test_that("get_label works", {
+  expect_snapshot(mtcars |> get_label(var = "mpg"))
+  expect_snapshot(mtcars |> get_label())
+  expect_snapshot(mtcars$mpg |> get_label())
+  expect_snapshot(gtsummary::trial |> get_label(var = "trt"))
+  expect_snapshot(1:10 |> get_label())
+})
+
+## line_break
+test_that("line_break works", {
+  expect_snapshot("Lorem ipsum... you know the routine" |> line_break())
+  expect_snapshot(paste(rep(letters, 5), collapse = "") |> line_break(force = TRUE, lineLength = 5))
+  expect_snapshot(paste(rep(letters, 5), collapse = "") |> line_break(force = FALSE))
+})