mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2025-09-12 09:59:39 +02:00
Compare commits
No commits in common. "2065c9c8005792cd472dc0095406805bf3473993" and "e463fa067057695125707613a7087f66ac392699" have entirely different histories.
2065c9c800
...
e463fa0670
44 changed files with 503 additions and 1546 deletions
|
|
@ -80,9 +80,7 @@ Suggests:
|
|||
rsconnect,
|
||||
knitr,
|
||||
rmarkdown,
|
||||
testthat (>= 3.0.0),
|
||||
shinytest,
|
||||
covr
|
||||
testthat (>= 3.0.0)
|
||||
URL: https://github.com/agdamsbo/FreesearchR, https://agdamsbo.github.io/FreesearchR/
|
||||
BugReports: https://github.com/agdamsbo/FreesearchR/issues
|
||||
VignetteBuilder: knitr
|
||||
|
|
|
|||
|
|
@ -5,13 +5,12 @@ S3method(cut_var,hms)
|
|||
S3method(plot,tbl_regression)
|
||||
export(add_class_icon)
|
||||
export(add_sparkline)
|
||||
export(align_axes)
|
||||
export(all_but)
|
||||
export(allign_axes)
|
||||
export(append_column)
|
||||
export(append_list)
|
||||
export(argsstring2list)
|
||||
export(baseline_table)
|
||||
export(class_icons)
|
||||
export(clean_common_axis)
|
||||
export(clean_date)
|
||||
export(clean_sep)
|
||||
|
|
@ -96,6 +95,7 @@ export(regression_model_uv_list)
|
|||
export(regression_table)
|
||||
export(remove_empty_attr)
|
||||
export(remove_empty_cols)
|
||||
export(remove_na_attr)
|
||||
export(remove_nested_list)
|
||||
export(repeated_instruments)
|
||||
export(sankey_ready)
|
||||
|
|
@ -108,7 +108,6 @@ export(supported_functions)
|
|||
export(supported_plots)
|
||||
export(symmetrical_scale_x_log10)
|
||||
export(tbl_merge)
|
||||
export(type_icons)
|
||||
export(update_factor_server)
|
||||
export(update_factor_ui)
|
||||
export(update_variables_server)
|
||||
|
|
@ -116,6 +115,7 @@ export(update_variables_ui)
|
|||
export(vectorSelectInput)
|
||||
export(vertical_stacked_bars)
|
||||
export(wide2long)
|
||||
export(winbox_cut_variable)
|
||||
export(winbox_update_factor)
|
||||
export(wrap_plot_list)
|
||||
export(write_quarto)
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
app_version <- function()'Version: 25.4.3.250415_1627'
|
||||
app_version <- function()'Version: 25.4.3.250414_1342'
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ create_baseline <- function(data, ..., by.var, add.p = FALSE, add.overall = FALS
|
|||
}
|
||||
}
|
||||
|
||||
suppressMessages(gtsummary::theme_gtsummary_journal(journal = theme))
|
||||
gtsummary::theme_gtsummary_journal(journal = theme)
|
||||
|
||||
args <- list(...)
|
||||
|
||||
|
|
|
|||
|
|
@ -46,8 +46,7 @@ data_correlations_server <- function(id,
|
|||
} else {
|
||||
out <- data()
|
||||
}
|
||||
# out |> dplyr::mutate(dplyr::across(tidyselect::everything(),as.numeric))
|
||||
sapply(out,as.numeric)
|
||||
out |> dplyr::mutate(dplyr::across(tidyselect::everything(),as.numeric))
|
||||
# as.numeric()
|
||||
})
|
||||
|
||||
|
|
@ -101,9 +100,8 @@ data_correlations_server <- function(id,
|
|||
}
|
||||
|
||||
correlation_pairs <- function(data, threshold = .8) {
|
||||
data <- as.data.frame(data)[!sapply(as.data.frame(data), is.character)]
|
||||
data <- sapply(data,\(.x)if (is.factor(.x)) as.numeric(.x) else .x) |> as.data.frame()
|
||||
# data <- data |> dplyr::mutate(dplyr::across(dplyr::where(is.factor), as.numeric))
|
||||
data <- data[!sapply(data, is.character)]
|
||||
data <- data |> dplyr::mutate(dplyr::across(dplyr::where(is.factor), as.numeric))
|
||||
cor <- Hmisc::rcorr(as.matrix(data))
|
||||
r <- cor$r %>% as.table()
|
||||
d <- r |>
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ cut_var <- function(x, ...) {
|
|||
#' @export
|
||||
#' @name cut_var
|
||||
cut_var.default <- function(x, ...) {
|
||||
base::cut(x, ...)
|
||||
base::cut.default(x, ...)
|
||||
}
|
||||
|
||||
#' @name cut_var
|
||||
|
|
@ -581,6 +581,36 @@ modal_cut_variable <- function(id,
|
|||
}
|
||||
|
||||
|
||||
#' @inheritParams shinyWidgets::WinBox
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom shinyWidgets WinBox wbOptions wbControls
|
||||
#' @importFrom htmltools tagList
|
||||
#' @rdname cut-variable
|
||||
winbox_cut_variable <- function(id,
|
||||
title = i18n("Convert Numeric to Factor"),
|
||||
options = shinyWidgets::wbOptions(),
|
||||
controls = shinyWidgets::wbControls()) {
|
||||
ns <- NS(id)
|
||||
WinBox(
|
||||
title = title,
|
||||
ui = tagList(
|
||||
cut_variable_ui(id),
|
||||
tags$div(
|
||||
style = "display: none;",
|
||||
textInput(inputId = ns("hidden"), label = NULL, value = genId())
|
||||
)
|
||||
),
|
||||
options = modifyList(
|
||||
shinyWidgets::wbOptions(height = "750px", modal = TRUE),
|
||||
options
|
||||
),
|
||||
controls = controls,
|
||||
auto_height = FALSE
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
#' @importFrom graphics abline axis hist par plot.new plot.window
|
||||
plot_histogram <- function(data, column, bins = 30, breaks = NULL, color = "#112466") {
|
||||
x <- data[[column]]
|
||||
|
|
@ -597,4 +627,3 @@ plot_histogram <- function(data, column, bins = 30, breaks = NULL, color = "#112
|
|||
abline(v = breaks, col = "#FFFFFF", lty = 1, lwd = 1.5)
|
||||
abline(v = breaks, col = "#2E2E2E", lty = 2, lwd = 1.5)
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -155,8 +155,8 @@ overview_vars <- function(data) {
|
|||
data <- as.data.frame(data)
|
||||
|
||||
dplyr::tibble(
|
||||
icon = data_type(data),
|
||||
type = icon,
|
||||
class = get_classes(data),
|
||||
type = data_type(data),
|
||||
name = names(data),
|
||||
n_missing = unname(colSums(is.na(data))),
|
||||
p_complete = 1 - n_missing / nrow(data),
|
||||
|
|
@ -188,7 +188,7 @@ create_overview_datagrid <- function(data,...) {
|
|||
|
||||
std_names <- c(
|
||||
"Name" = "name",
|
||||
"Icon" = "icon",
|
||||
"Class" = "class",
|
||||
"Type" = "type",
|
||||
"Missings" = "n_missing",
|
||||
"Complete" = "p_complete",
|
||||
|
|
@ -226,7 +226,7 @@ create_overview_datagrid <- function(data,...) {
|
|||
|
||||
grid <- toastui::grid_columns(
|
||||
grid = grid,
|
||||
columns = "icon",
|
||||
columns = "class",
|
||||
header = " ",
|
||||
align = "center",sortable = FALSE,
|
||||
width = 40
|
||||
|
|
@ -234,8 +234,7 @@ create_overview_datagrid <- function(data,...) {
|
|||
|
||||
grid <- add_class_icon(
|
||||
grid = grid,
|
||||
column = "icon",
|
||||
fun = type_icons
|
||||
column = "class"
|
||||
)
|
||||
|
||||
grid <- toastui::grid_format(
|
||||
|
|
@ -272,41 +271,14 @@ create_overview_datagrid <- function(data,...) {
|
|||
#' overview_vars() |>
|
||||
#' toastui::datagrid() |>
|
||||
#' add_class_icon()
|
||||
add_class_icon <- function(grid, column = "class", fun=class_icons) {
|
||||
add_class_icon <- function(grid, column = "class") {
|
||||
out <- toastui::grid_format(
|
||||
grid = grid,
|
||||
column = column,
|
||||
formatter = function(value) {
|
||||
lapply(
|
||||
X = value,
|
||||
FUN = fun
|
||||
)
|
||||
}
|
||||
)
|
||||
|
||||
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 {
|
||||
FUN = function(x) {
|
||||
if (identical(x, "numeric")) {
|
||||
shiny::icon("calculator")
|
||||
} else if (identical(x, "factor")) {
|
||||
|
|
@ -323,39 +295,16 @@ class_icons <- function(x) {
|
|||
shiny::icon("clock")
|
||||
} else {
|
||||
shiny::icon("table")
|
||||
}}
|
||||
}
|
||||
}
|
||||
}
|
||||
)
|
||||
}
|
||||
)
|
||||
|
||||
#' Get data type icons
|
||||
#'
|
||||
#' @param x character vector of data classes
|
||||
#'
|
||||
#' @returns list
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' "ordinal" |> type_icons()
|
||||
#' default_parsing(mtcars) |> sapply(data_type) |> type_icons()
|
||||
type_icons <- function(x) {
|
||||
if (length(x)>1){
|
||||
lapply(x,class_icons)
|
||||
} else {
|
||||
if (identical(x, "continuous")) {
|
||||
shiny::icon("calculator")
|
||||
} else if (identical(x, "categorical")) {
|
||||
shiny::icon("chart-simple")
|
||||
} else if (identical(x, "ordinal")) {
|
||||
shiny::icon("arrow-down-1-9")
|
||||
} else if (identical(x, "text")) {
|
||||
shiny::icon("arrow-down-a-z")
|
||||
} else if (identical(x, "dichotomous")) {
|
||||
shiny::icon("toggle-off")
|
||||
} else if (identical(x,"datetime")) {
|
||||
shiny::icon("calendar-days")
|
||||
} else if (identical(x,"id")) {
|
||||
shiny::icon("id-card")
|
||||
} else {
|
||||
shiny::icon("table")
|
||||
}
|
||||
}
|
||||
toastui::grid_columns(
|
||||
grid = out,
|
||||
header = NULL,
|
||||
columns = column,
|
||||
width = 60
|
||||
)
|
||||
}
|
||||
|
|
|
|||
111
R/data_plots.R
111
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,21 +318,29 @@ 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"]],
|
||||
pri = input$primary,
|
||||
sec = input$secondary,
|
||||
ter = input$tertiary
|
||||
x = input$primary,
|
||||
y = input$secondary,
|
||||
z = input$tertiary
|
||||
)
|
||||
|
||||
shiny::withProgress(message = "Drawing the plot. Hold tight for a moment..", {
|
||||
rv$plot <- rlang::exec(create_plot, !!!append_list(data(), parameters, "data"))
|
||||
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")
|
||||
|
|
@ -340,8 +348,7 @@ data_visuals_server <- function(id,
|
|||
error = function(err) {
|
||||
showNotification(paste0(err), type = "err")
|
||||
}
|
||||
)
|
||||
}
|
||||
)}
|
||||
},
|
||||
ignoreInit = TRUE
|
||||
)
|
||||
|
|
@ -408,7 +415,7 @@ all_but <- function(data, ...) {
|
|||
#'
|
||||
#' @examples
|
||||
#' default_parsing(mtcars) |> subset_types("ordinal")
|
||||
#' default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal", "categorical"))
|
||||
#' default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal" ,"categorical"))
|
||||
#' #' default_parsing(mtcars) |> subset_types("factor",class)
|
||||
subset_types <- function(data, types, type.fun = data_type) {
|
||||
data[sapply(data, type.fun) %in% types]
|
||||
|
|
@ -443,21 +450,21 @@ supported_plots <- function() {
|
|||
fun = "plot_hbars",
|
||||
descr = "Stacked horizontal bars",
|
||||
note = "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars",
|
||||
primary.type = c("dichotomous", "ordinal", "categorical"),
|
||||
secondary.type = c("dichotomous", "ordinal", "categorical"),
|
||||
primary.type = c("dichotomous", "ordinal" ,"categorical"),
|
||||
secondary.type = c("dichotomous", "ordinal" ,"categorical"),
|
||||
secondary.multi = FALSE,
|
||||
tertiary.type = c("dichotomous", "ordinal", "categorical"),
|
||||
tertiary.type = c("dichotomous", "ordinal" ,"categorical"),
|
||||
secondary.extra = "none"
|
||||
),
|
||||
plot_violin = list(
|
||||
fun = "plot_violin",
|
||||
descr = "Violin plot",
|
||||
note = "A modern alternative to the classic boxplot to visualise data distribution",
|
||||
primary.type = c("datatime", "continuous", "dichotomous", "ordinal", "categorical"),
|
||||
secondary.type = c("dichotomous", "ordinal", "categorical"),
|
||||
primary.type = c("datatime","continuous", "dichotomous", "ordinal" ,"categorical"),
|
||||
secondary.type = c("dichotomous", "ordinal" ,"categorical"),
|
||||
secondary.multi = FALSE,
|
||||
secondary.extra = "none",
|
||||
tertiary.type = c("dichotomous", "ordinal", "categorical")
|
||||
tertiary.type = c("dichotomous", "ordinal" ,"categorical")
|
||||
),
|
||||
# plot_ridge = list(
|
||||
# descr = "Ridge plot",
|
||||
|
|
@ -471,30 +478,30 @@ supported_plots <- function() {
|
|||
fun = "plot_sankey",
|
||||
descr = "Sankey plot",
|
||||
note = "A way of visualising change between groups",
|
||||
primary.type = c("dichotomous", "ordinal", "categorical"),
|
||||
secondary.type = c("dichotomous", "ordinal", "categorical"),
|
||||
primary.type = c("dichotomous", "ordinal" ,"categorical"),
|
||||
secondary.type = c("dichotomous", "ordinal" ,"categorical"),
|
||||
secondary.multi = FALSE,
|
||||
secondary.extra = NULL,
|
||||
tertiary.type = c("dichotomous", "ordinal", "categorical")
|
||||
tertiary.type = c("dichotomous", "ordinal" ,"categorical")
|
||||
),
|
||||
plot_scatter = list(
|
||||
fun = "plot_scatter",
|
||||
descr = "Scatter plot",
|
||||
note = "A classic way of showing the association between to variables",
|
||||
primary.type = c("datatime", "continuous"),
|
||||
secondary.type = c("datatime", "continuous", "ordinal", "categorical"),
|
||||
primary.type = c("datatime","continuous"),
|
||||
secondary.type = c("datatime","continuous", "ordinal" ,"categorical"),
|
||||
secondary.multi = FALSE,
|
||||
tertiary.type = c("dichotomous", "ordinal", "categorical"),
|
||||
tertiary.type = c("dichotomous", "ordinal" ,"categorical"),
|
||||
secondary.extra = NULL
|
||||
),
|
||||
plot_box = list(
|
||||
fun = "plot_box",
|
||||
descr = "Box plot",
|
||||
note = "A classic way to plot data distribution by groups",
|
||||
primary.type = c("datatime", "continuous", "dichotomous", "ordinal", "categorical"),
|
||||
secondary.type = c("dichotomous", "ordinal", "categorical"),
|
||||
primary.type = c("datatime","continuous", "dichotomous", "ordinal" ,"categorical"),
|
||||
secondary.type = c("dichotomous", "ordinal" ,"categorical"),
|
||||
secondary.multi = FALSE,
|
||||
tertiary.type = c("dichotomous", "ordinal", "categorical"),
|
||||
tertiary.type = c("dichotomous", "ordinal" ,"categorical"),
|
||||
secondary.extra = "none"
|
||||
),
|
||||
plot_euler = list(
|
||||
|
|
@ -505,7 +512,7 @@ supported_plots <- function() {
|
|||
secondary.type = "dichotomous",
|
||||
secondary.multi = TRUE,
|
||||
secondary.max = 4,
|
||||
tertiary.type = c("dichotomous", "ordinal", "categorical"),
|
||||
tertiary.type = c("dichotomous", "ordinal" ,"categorical"),
|
||||
secondary.extra = NULL
|
||||
)
|
||||
)
|
||||
|
|
@ -584,9 +591,9 @@ get_plot_options <- function(data) {
|
|||
#' Wrapper to create plot based on provided type
|
||||
#'
|
||||
#' @param data data.frame
|
||||
#' @param pri primary variable
|
||||
#' @param sec secondary variable
|
||||
#' @param ter tertiary variable
|
||||
#' @param x primary variable
|
||||
#' @param y secondary variable
|
||||
#' @param z tertiary variable
|
||||
#' @param type plot type (derived from possible_plots() and matches custom function)
|
||||
#' @param ... ignored for now
|
||||
#'
|
||||
|
|
@ -596,36 +603,20 @@ get_plot_options <- function(data) {
|
|||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes()
|
||||
create_plot <- function(data, type, pri, sec, ter = NULL, ...) {
|
||||
if (!is.null(sec)) {
|
||||
if (!any(sec %in% names(data))) {
|
||||
sec <- NULL
|
||||
}
|
||||
#' create_plot(mtcars, "plot_violin", "mpg", "cyl")
|
||||
create_plot <- function(data, type, x, y, z = NULL, ...) {
|
||||
if (!any(y %in% names(data))) {
|
||||
y <- NULL
|
||||
}
|
||||
|
||||
if (!is.null(ter)) {
|
||||
if (!ter %in% names(data)) {
|
||||
ter <- NULL
|
||||
}
|
||||
if (!z %in% names(data)) {
|
||||
z <- NULL
|
||||
}
|
||||
|
||||
parameters <- list(
|
||||
pri = pri,
|
||||
sec = sec,
|
||||
ter = ter,
|
||||
...
|
||||
)
|
||||
|
||||
out <- do.call(
|
||||
do.call(
|
||||
type,
|
||||
modifyList(parameters,list(data=data))
|
||||
list(data, x, y, z, ...)
|
||||
)
|
||||
|
||||
code <- rlang::call2(type,!!!parameters,.ns = "FreesearchR")
|
||||
|
||||
attr(out,"code") <- code
|
||||
out
|
||||
}
|
||||
|
||||
#' Print label, and if missing print variable name
|
||||
|
|
@ -675,8 +666,8 @@ get_label <- function(data, var = NULL) {
|
|||
#'
|
||||
#' @examples
|
||||
#' "Lorem ipsum... you know the routine" |> line_break()
|
||||
#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE)
|
||||
line_break <- function(data, lineLength = 20, force = FALSE) {
|
||||
#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(fixed = TRUE)
|
||||
line_break <- function(data, lineLength = 20, fixed = FALSE) {
|
||||
if (isTRUE(force)) {
|
||||
gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), "\\1\n", data)
|
||||
} else {
|
||||
|
|
@ -707,7 +698,7 @@ wrap_plot_list <- function(data, tag_levels = NULL) {
|
|||
.x
|
||||
}
|
||||
})() |>
|
||||
align_axes() |>
|
||||
allign_axes() |>
|
||||
patchwork::wrap_plots(guides = "collect", axes = "collect", axis_titles = "collect")
|
||||
if (!is.null(tag_levels)) {
|
||||
out <- out + patchwork::plot_annotation(tag_levels = tag_levels)
|
||||
|
|
@ -722,21 +713,19 @@ wrap_plot_list <- function(data, tag_levels = NULL) {
|
|||
}
|
||||
|
||||
|
||||
#' Aligns axes between plots
|
||||
#' Alligns axes between plots
|
||||
#'
|
||||
#' @param ... ggplot2 objects or list of ggplot2 objects
|
||||
#'
|
||||
#' @returns list of ggplot2 objects
|
||||
#' @export
|
||||
#'
|
||||
align_axes <- function(...) {
|
||||
allign_axes <- function(...) {
|
||||
# https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object
|
||||
# https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150
|
||||
if (ggplot2::is.ggplot(..1)) {
|
||||
## Assumes list of ggplots
|
||||
p <- list(...)
|
||||
} else if (is.list(..1)) {
|
||||
## Assumes list with list of ggplots
|
||||
p <- ..1
|
||||
} else {
|
||||
cli::cli_abort("Can only align {.cls ggplot} objects or a list of them")
|
||||
|
|
|
|||
|
|
@ -357,7 +357,7 @@ data_description <- function(data, data_text = "Data") {
|
|||
p_complete <- n_complete / n
|
||||
|
||||
sprintf(
|
||||
"%s has %s observations and %s variables, with %s (%s%%) complete cases.",
|
||||
i18n("%s has %s observations and %s variables, with %s (%s%%) complete cases."),
|
||||
data_text,
|
||||
n,
|
||||
n_var,
|
||||
|
|
|
|||
27
R/plot_box.R
27
R/plot_box.R
|
|
@ -6,13 +6,13 @@
|
|||
#' @name data-plots
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> plot_box(pri = "mpg", sec = "cyl", ter = "gear")
|
||||
#' mtcars |> plot_box(x = "mpg", y = "cyl", z = "gear")
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' plot_box(pri = "mpg", sec = "cyl", ter = "gear")
|
||||
plot_box <- function(data, pri, sec, ter = NULL) {
|
||||
if (!is.null(ter)) {
|
||||
ds <- split(data, data[ter])
|
||||
#' plot_box(x = "mpg", y = "cyl", z = "gear")
|
||||
plot_box <- function(data, x, y, z = NULL) {
|
||||
if (!is.null(z)) {
|
||||
ds <- split(data, data[z])
|
||||
} else {
|
||||
ds <- list(data)
|
||||
}
|
||||
|
|
@ -20,12 +20,13 @@ plot_box <- function(data, pri, sec, ter = NULL) {
|
|||
out <- lapply(ds, \(.ds){
|
||||
plot_box_single(
|
||||
data = .ds,
|
||||
pri = pri,
|
||||
sec = sec
|
||||
x = x,
|
||||
y = y
|
||||
)
|
||||
})
|
||||
|
||||
wrap_plot_list(out)
|
||||
# patchwork::wrap_plots(out,guides = "collect")
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -40,18 +41,18 @@ plot_box <- function(data, pri, sec, ter = NULL) {
|
|||
#'
|
||||
#' @examples
|
||||
#' mtcars |> plot_box_single("mpg","cyl")
|
||||
plot_box_single <- function(data, pri, sec=NULL, seed = 2103) {
|
||||
plot_box_single <- function(data, x, y=NULL, seed = 2103) {
|
||||
set.seed(seed)
|
||||
|
||||
if (is.null(sec)) {
|
||||
sec <- "All"
|
||||
data[[y]] <- sec
|
||||
if (is.null(y)) {
|
||||
y <- "All"
|
||||
data[[y]] <- y
|
||||
}
|
||||
|
||||
discrete <- !data_type(data[[sec]]) %in% "continuous"
|
||||
discrete <- !data_type(data[[y]]) %in% "continuous"
|
||||
|
||||
data |>
|
||||
ggplot2::ggplot(ggplot2::aes(x = !!dplyr::sym(pri), y = !!dplyr::sym(sec), fill = !!dplyr::sym(sec), group = !!dplyr::sym(sec))) +
|
||||
ggplot2::ggplot(ggplot2::aes(x = !!dplyr::sym(x), y = !!dplyr::sym(y), fill = !!dplyr::sym(y), group = !!dplyr::sym(y))) +
|
||||
ggplot2::geom_boxplot(linewidth = 1.8, outliers = FALSE) +
|
||||
## THis could be optional in future
|
||||
ggplot2::geom_jitter(color = "black", size = 2, alpha = 0.9, width = 0.1, height = .5) +
|
||||
|
|
|
|||
|
|
@ -76,16 +76,16 @@ ggeulerr <- function(
|
|||
#' D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE)
|
||||
#' ) |> plot_euler("A", c("B", "C"), "D", seed = 4)
|
||||
#' mtcars |> plot_euler("vs", "am", seed = 1)
|
||||
plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) {
|
||||
plot_euler <- function(data, x, y, z = NULL, seed = 2103) {
|
||||
set.seed(seed = seed)
|
||||
if (!is.null(ter)) {
|
||||
ds <- split(data, data[ter])
|
||||
if (!is.null(z)) {
|
||||
ds <- split(data, data[z])
|
||||
} else {
|
||||
ds <- list(data)
|
||||
}
|
||||
|
||||
out <- lapply(ds, \(.x){
|
||||
.x[c(pri, sec)] |>
|
||||
.x[c(x, y)] |>
|
||||
as.data.frame() |>
|
||||
plot_euler_single()
|
||||
})
|
||||
|
|
@ -95,6 +95,7 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) {
|
|||
# patchwork::wrap_plots(out, guides = "collect")
|
||||
}
|
||||
|
||||
?withCallingHandlers()
|
||||
#' Easily plot single euler diagrams
|
||||
#'
|
||||
#' @returns ggplot2 object
|
||||
|
|
|
|||
|
|
@ -6,10 +6,10 @@
|
|||
#' @name data-plots
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> plot_hbars(pri = "carb", sec = "cyl")
|
||||
#' mtcars |> plot_hbars(pri = "carb", sec = NULL)
|
||||
plot_hbars <- function(data, pri, sec, ter = NULL) {
|
||||
out <- vertical_stacked_bars(data = data, score = pri, group = sec, strata = ter)
|
||||
#' mtcars |> plot_hbars(x = "carb", y = "cyl")
|
||||
#' mtcars |> plot_hbars(x = "carb", y = NULL)
|
||||
plot_hbars <- function(data, x, y, z = NULL) {
|
||||
out <- vertical_stacked_bars(data = data, score = x, group = y, strata = z)
|
||||
|
||||
out
|
||||
}
|
||||
|
|
|
|||
|
|
@ -15,42 +15,42 @@
|
|||
#' last = sample(c(TRUE, FALSE, FALSE), 100, TRUE)
|
||||
#' ) |>
|
||||
#' sankey_ready("first", "last")
|
||||
sankey_ready <- function(data, pri, sec, numbers = "count", ...) {
|
||||
sankey_ready <- function(data, x, y, numbers = "count", ...) {
|
||||
## TODO: Ensure ordering x and y
|
||||
|
||||
## Ensure all are factors
|
||||
data[c(pri, sec)] <- data[c(pri, sec)] |>
|
||||
data[c(x, y)] <- data[c(x, y)] |>
|
||||
dplyr::mutate(dplyr::across(!dplyr::where(is.factor), forcats::as_factor))
|
||||
|
||||
out <- dplyr::count(data, !!dplyr::sym(pri), !!dplyr::sym(sec))
|
||||
out <- dplyr::count(data, !!dplyr::sym(x), !!dplyr::sym(y))
|
||||
|
||||
out <- out |>
|
||||
dplyr::group_by(!!dplyr::sym(pri)) |>
|
||||
dplyr::group_by(!!dplyr::sym(x)) |>
|
||||
dplyr::mutate(gx.sum = sum(n)) |>
|
||||
dplyr::ungroup() |>
|
||||
dplyr::group_by(!!dplyr::sym(sec)) |>
|
||||
dplyr::group_by(!!dplyr::sym(y)) |>
|
||||
dplyr::mutate(gy.sum = sum(n)) |>
|
||||
dplyr::ungroup()
|
||||
|
||||
if (numbers == "count") {
|
||||
out <- out |> dplyr::mutate(
|
||||
lx = factor(paste0(!!dplyr::sym(pri), "\n(n=", gx.sum, ")")),
|
||||
ly = factor(paste0(!!dplyr::sym(sec), "\n(n=", gy.sum, ")"))
|
||||
lx = factor(paste0(!!dplyr::sym(x), "\n(n=", gx.sum, ")")),
|
||||
ly = factor(paste0(!!dplyr::sym(y), "\n(n=", gy.sum, ")"))
|
||||
)
|
||||
} else if (numbers == "percentage") {
|
||||
out <- out |> dplyr::mutate(
|
||||
lx = factor(paste0(!!dplyr::sym(pri), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)")),
|
||||
ly = factor(paste0(!!dplyr::sym(sec), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)"))
|
||||
lx = factor(paste0(!!dplyr::sym(x), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)")),
|
||||
ly = factor(paste0(!!dplyr::sym(y), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)"))
|
||||
)
|
||||
}
|
||||
|
||||
if (is.factor(data[[pri]])) {
|
||||
index <- match(levels(data[[pri]]), str_remove_last(levels(out$lx), "\n"))
|
||||
if (is.factor(data[[x]])) {
|
||||
index <- match(levels(data[[x]]), str_remove_last(levels(out$lx), "\n"))
|
||||
out$lx <- factor(out$lx, levels = levels(out$lx)[index])
|
||||
}
|
||||
|
||||
if (is.factor(data[[sec]])) {
|
||||
index <- match(levels(data[[sec]]), str_remove_last(levels(out$ly), "\n"))
|
||||
if (is.factor(data[[y]])) {
|
||||
index <- match(levels(data[[y]]), str_remove_last(levels(out$ly), "\n"))
|
||||
out$ly <- factor(out$ly, levels = levels(out$ly)[index])
|
||||
}
|
||||
|
||||
|
|
@ -75,15 +75,15 @@ str_remove_last <- function(data, pattern = "\n") {
|
|||
#' ds |> plot_sankey("first", "last")
|
||||
#' ds |> plot_sankey("first", "last", color.group = "y")
|
||||
#' ds |> plot_sankey("first", "last", z = "g", color.group = "y")
|
||||
plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "x", colors = NULL) {
|
||||
if (!is.null(ter)) {
|
||||
ds <- split(data, data[ter])
|
||||
plot_sankey <- function(data, x, y, z = NULL, color.group = "x", colors = NULL) {
|
||||
if (!is.null(z)) {
|
||||
ds <- split(data, data[z])
|
||||
} else {
|
||||
ds <- list(data)
|
||||
}
|
||||
|
||||
out <- lapply(ds, \(.ds){
|
||||
plot_sankey_single(.ds, x = pri, y = sec, color.group = color.group, colors = colors)
|
||||
plot_sankey_single(.ds, x = x, y = y, color.group = color.group, colors = colors)
|
||||
})
|
||||
|
||||
patchwork::wrap_plots(out)
|
||||
|
|
@ -112,10 +112,10 @@ default_theme <- function() {
|
|||
#' first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)),
|
||||
#' last = sample(c(TRUE, FALSE, FALSE), 100, TRUE)
|
||||
#' ) |>
|
||||
#' plot_sankey_single("first", "last", color.group = "pri")
|
||||
plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), colors = NULL, ...) {
|
||||
#' plot_sankey_single("first", "last", color.group = "x")
|
||||
plot_sankey_single <- function(data, x, y, color.group = c("x", "y"), colors = NULL, ...) {
|
||||
color.group <- match.arg(color.group)
|
||||
data <- data |> sankey_ready(pri = pri, sec = sec, ...)
|
||||
data <- data |> sankey_ready(x = x, y = y, ...)
|
||||
|
||||
library(ggalluvial)
|
||||
|
||||
|
|
@ -123,13 +123,13 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
|
|||
box.color <- "#1E4B66"
|
||||
|
||||
if (is.null(colors)) {
|
||||
if (color.group == "sec") {
|
||||
main.colors <- viridisLite::viridis(n = length(levels(data[[sec]])))
|
||||
secondary.colors <- rep(na.color, length(levels(data[[pri]])))
|
||||
if (color.group == "y") {
|
||||
main.colors <- viridisLite::viridis(n = length(levels(data[[y]])))
|
||||
secondary.colors <- rep(na.color, length(levels(data[[x]])))
|
||||
label.colors <- Reduce(c, lapply(list(secondary.colors, rev(main.colors)), contrast_text))
|
||||
} else {
|
||||
main.colors <- viridisLite::viridis(n = length(levels(data[[pri]])))
|
||||
secondary.colors <- rep(na.color, length(levels(data[[sec]])))
|
||||
main.colors <- viridisLite::viridis(n = length(levels(data[[x]])))
|
||||
secondary.colors <- rep(na.color, length(levels(data[[y]])))
|
||||
label.colors <- Reduce(c, lapply(list(rev(main.colors), secondary.colors), contrast_text))
|
||||
}
|
||||
colors <- c(na.color, main.colors, secondary.colors)
|
||||
|
|
@ -137,33 +137,33 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
|
|||
label.colors <- contrast_text(colors)
|
||||
}
|
||||
|
||||
group_labels <- c(get_label(data, pri), get_label(data, sec)) |>
|
||||
group_labels <- c(get_label(data, x), get_label(data, y)) |>
|
||||
sapply(line_break) |>
|
||||
unname()
|
||||
|
||||
p <- ggplot2::ggplot(data, ggplot2::aes(y = n, axis1 = lx, axis2 = ly))
|
||||
|
||||
if (color.group == "sec") {
|
||||
if (color.group == "y") {
|
||||
p <- p +
|
||||
ggalluvial::geom_alluvium(
|
||||
ggplot2::aes(fill = !!dplyr::sym(sec), color = !!dplyr::sym(sec)),
|
||||
ggplot2::aes(fill = !!dplyr::sym(y), color = !!dplyr::sym(y)),
|
||||
width = 1 / 16,
|
||||
alpha = .8,
|
||||
knot.pos = 0.4,
|
||||
curve_type = "sigmoid"
|
||||
) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(sec)),
|
||||
) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(y)),
|
||||
size = 2,
|
||||
width = 1 / 3.4
|
||||
)
|
||||
} else {
|
||||
p <- p +
|
||||
ggalluvial::geom_alluvium(
|
||||
ggplot2::aes(fill = !!dplyr::sym(pri), color = !!dplyr::sym(pri)),
|
||||
ggplot2::aes(fill = !!dplyr::sym(x), color = !!dplyr::sym(x)),
|
||||
width = 1 / 16,
|
||||
alpha = .8,
|
||||
knot.pos = 0.4,
|
||||
curve_type = "sigmoid"
|
||||
) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(pri)),
|
||||
) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(x)),
|
||||
size = 2,
|
||||
width = 1 / 3.4
|
||||
)
|
||||
|
|
|
|||
|
|
@ -6,24 +6,20 @@
|
|||
#' @name data-plots
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> plot_scatter(pri = "mpg", sec = "wt")
|
||||
plot_scatter <- function(data, pri, sec, ter = NULL) {
|
||||
if (is.null(ter)) {
|
||||
#' mtcars |> plot_scatter(x = "mpg", y = "wt")
|
||||
plot_scatter <- function(data, x, y, z = NULL) {
|
||||
if (is.null(z)) {
|
||||
rempsyc::nice_scatter(
|
||||
data = data,
|
||||
predictor = sec,
|
||||
response = pri,
|
||||
xtitle = get_label(data, var = sec),
|
||||
ytitle = get_label(data, var = pri)
|
||||
predictor = y,
|
||||
response = x, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x)
|
||||
)
|
||||
} else {
|
||||
rempsyc::nice_scatter(
|
||||
data = data,
|
||||
predictor = sec,
|
||||
response = pri,
|
||||
group = ter,
|
||||
xtitle = get_label(data, var = sec),
|
||||
ytitle = get_label(data, var = pri)
|
||||
predictor = y,
|
||||
response = x,
|
||||
group = z, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x)
|
||||
)
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -6,10 +6,10 @@
|
|||
#' @name data-plots
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear")
|
||||
plot_violin <- function(data, pri, sec, ter = NULL) {
|
||||
if (!is.null(ter)) {
|
||||
ds <- split(data, data[ter])
|
||||
#' mtcars |> plot_violin(x = "mpg", y = "cyl", z = "gear")
|
||||
plot_violin <- function(data, x, y, z = NULL) {
|
||||
if (!is.null(z)) {
|
||||
ds <- split(data, data[z])
|
||||
} else {
|
||||
ds <- list(data)
|
||||
}
|
||||
|
|
@ -17,10 +17,8 @@ plot_violin <- function(data, pri, sec, ter = NULL) {
|
|||
out <- lapply(ds, \(.ds){
|
||||
rempsyc::nice_violin(
|
||||
data = .ds,
|
||||
group = sec,
|
||||
response = pri,
|
||||
xtitle = get_label(data, var = sec),
|
||||
ytitle = get_label(data, var = pri)
|
||||
group = y,
|
||||
response = x, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x)
|
||||
)
|
||||
})
|
||||
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@
|
|||
#### Current file: /Users/au301842/FreesearchR/R//app_version.R
|
||||
########
|
||||
|
||||
app_version <- function()'Version: 25.4.3.250415_1627'
|
||||
app_version <- function()'Version: 25.4.3.250414_1342'
|
||||
|
||||
|
||||
########
|
||||
|
|
@ -68,7 +68,7 @@ create_baseline <- function(data, ..., by.var, add.p = FALSE, add.overall = FALS
|
|||
}
|
||||
}
|
||||
|
||||
suppressMessages(gtsummary::theme_gtsummary_journal(journal = theme))
|
||||
gtsummary::theme_gtsummary_journal(journal = theme)
|
||||
|
||||
args <- list(...)
|
||||
|
||||
|
|
@ -207,8 +207,7 @@ data_correlations_server <- function(id,
|
|||
} else {
|
||||
out <- data()
|
||||
}
|
||||
# out |> dplyr::mutate(dplyr::across(tidyselect::everything(),as.numeric))
|
||||
sapply(out,as.numeric)
|
||||
out |> dplyr::mutate(dplyr::across(tidyselect::everything(),as.numeric))
|
||||
# as.numeric()
|
||||
})
|
||||
|
||||
|
|
@ -262,9 +261,8 @@ data_correlations_server <- function(id,
|
|||
}
|
||||
|
||||
correlation_pairs <- function(data, threshold = .8) {
|
||||
data <- as.data.frame(data)[!sapply(as.data.frame(data), is.character)]
|
||||
data <- sapply(data,\(.x)if (is.factor(.x)) as.numeric(.x) else .x) |> as.data.frame()
|
||||
# data <- data |> dplyr::mutate(dplyr::across(dplyr::where(is.factor), as.numeric))
|
||||
data <- data[!sapply(data, is.character)]
|
||||
data <- data |> dplyr::mutate(dplyr::across(dplyr::where(is.factor), as.numeric))
|
||||
cor <- Hmisc::rcorr(as.matrix(data))
|
||||
r <- cor$r %>% as.table()
|
||||
d <- r |>
|
||||
|
|
@ -518,7 +516,7 @@ cut_var <- function(x, ...) {
|
|||
#' @export
|
||||
#' @name cut_var
|
||||
cut_var.default <- function(x, ...) {
|
||||
base::cut(x, ...)
|
||||
base::cut.default(x, ...)
|
||||
}
|
||||
|
||||
#' @name cut_var
|
||||
|
|
@ -1081,6 +1079,36 @@ modal_cut_variable <- function(id,
|
|||
}
|
||||
|
||||
|
||||
#' @inheritParams shinyWidgets::WinBox
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom shinyWidgets WinBox wbOptions wbControls
|
||||
#' @importFrom htmltools tagList
|
||||
#' @rdname cut-variable
|
||||
winbox_cut_variable <- function(id,
|
||||
title = i18n("Convert Numeric to Factor"),
|
||||
options = shinyWidgets::wbOptions(),
|
||||
controls = shinyWidgets::wbControls()) {
|
||||
ns <- NS(id)
|
||||
WinBox(
|
||||
title = title,
|
||||
ui = tagList(
|
||||
cut_variable_ui(id),
|
||||
tags$div(
|
||||
style = "display: none;",
|
||||
textInput(inputId = ns("hidden"), label = NULL, value = genId())
|
||||
)
|
||||
),
|
||||
options = modifyList(
|
||||
shinyWidgets::wbOptions(height = "750px", modal = TRUE),
|
||||
options
|
||||
),
|
||||
controls = controls,
|
||||
auto_height = FALSE
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
#' @importFrom graphics abline axis hist par plot.new plot.window
|
||||
plot_histogram <- function(data, column, bins = 30, breaks = NULL, color = "#112466") {
|
||||
x <- data[[column]]
|
||||
|
|
@ -1099,7 +1127,6 @@ plot_histogram <- function(data, column, bins = 30, breaks = NULL, color = "#112
|
|||
}
|
||||
|
||||
|
||||
|
||||
########
|
||||
#### Current file: /Users/au301842/FreesearchR/R//data_plots.R
|
||||
########
|
||||
|
|
@ -1194,7 +1221,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) {
|
|||
),
|
||||
bslib::nav_panel(
|
||||
title = tab_title,
|
||||
shiny::plotOutput(ns("plot"), height = "70vh"),
|
||||
shiny::plotOutput(ns("plot"),height = "70vh"),
|
||||
shiny::tags$br(),
|
||||
shiny::tags$br(),
|
||||
shiny::htmlOutput(outputId = ns("code_plot"))
|
||||
|
|
@ -1221,7 +1248,7 @@ data_visuals_server <- function(id,
|
|||
rv <- shiny::reactiveValues(
|
||||
plot.params = NULL,
|
||||
plot = NULL,
|
||||
code = NULL
|
||||
code=NULL
|
||||
)
|
||||
|
||||
# ## --- New attempt
|
||||
|
|
@ -1322,7 +1349,7 @@ data_visuals_server <- function(id,
|
|||
shiny::req(data())
|
||||
columnSelectInput(
|
||||
inputId = ns("primary"),
|
||||
col_subset = names(data())[sapply(data(), data_type) != "text"],
|
||||
col_subset=names(data())[sapply(data(),data_type)!="text"],
|
||||
data = data,
|
||||
placeholder = "Select variable",
|
||||
label = "Response variable",
|
||||
|
|
@ -1424,21 +1451,29 @@ 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"]],
|
||||
pri = input$primary,
|
||||
sec = input$secondary,
|
||||
ter = input$tertiary
|
||||
x = input$primary,
|
||||
y = input$secondary,
|
||||
z = input$tertiary
|
||||
)
|
||||
|
||||
shiny::withProgress(message = "Drawing the plot. Hold tight for a moment..", {
|
||||
rv$plot <- rlang::exec(create_plot, !!!append_list(data(), parameters, "data"))
|
||||
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")
|
||||
|
|
@ -1446,8 +1481,7 @@ data_visuals_server <- function(id,
|
|||
error = function(err) {
|
||||
showNotification(paste0(err), type = "err")
|
||||
}
|
||||
)
|
||||
}
|
||||
)}
|
||||
},
|
||||
ignoreInit = TRUE
|
||||
)
|
||||
|
|
@ -1514,7 +1548,7 @@ all_but <- function(data, ...) {
|
|||
#'
|
||||
#' @examples
|
||||
#' default_parsing(mtcars) |> subset_types("ordinal")
|
||||
#' default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal", "categorical"))
|
||||
#' default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal" ,"categorical"))
|
||||
#' #' default_parsing(mtcars) |> subset_types("factor",class)
|
||||
subset_types <- function(data, types, type.fun = data_type) {
|
||||
data[sapply(data, type.fun) %in% types]
|
||||
|
|
@ -1549,21 +1583,21 @@ supported_plots <- function() {
|
|||
fun = "plot_hbars",
|
||||
descr = "Stacked horizontal bars",
|
||||
note = "A classical way of visualising the distribution of an ordinal scale like the modified Ranking Scale and known as Grotta bars",
|
||||
primary.type = c("dichotomous", "ordinal", "categorical"),
|
||||
secondary.type = c("dichotomous", "ordinal", "categorical"),
|
||||
primary.type = c("dichotomous", "ordinal" ,"categorical"),
|
||||
secondary.type = c("dichotomous", "ordinal" ,"categorical"),
|
||||
secondary.multi = FALSE,
|
||||
tertiary.type = c("dichotomous", "ordinal", "categorical"),
|
||||
tertiary.type = c("dichotomous", "ordinal" ,"categorical"),
|
||||
secondary.extra = "none"
|
||||
),
|
||||
plot_violin = list(
|
||||
fun = "plot_violin",
|
||||
descr = "Violin plot",
|
||||
note = "A modern alternative to the classic boxplot to visualise data distribution",
|
||||
primary.type = c("datatime", "continuous", "dichotomous", "ordinal", "categorical"),
|
||||
secondary.type = c("dichotomous", "ordinal", "categorical"),
|
||||
primary.type = c("datatime","continuous", "dichotomous", "ordinal" ,"categorical"),
|
||||
secondary.type = c("dichotomous", "ordinal" ,"categorical"),
|
||||
secondary.multi = FALSE,
|
||||
secondary.extra = "none",
|
||||
tertiary.type = c("dichotomous", "ordinal", "categorical")
|
||||
tertiary.type = c("dichotomous", "ordinal" ,"categorical")
|
||||
),
|
||||
# plot_ridge = list(
|
||||
# descr = "Ridge plot",
|
||||
|
|
@ -1577,30 +1611,30 @@ supported_plots <- function() {
|
|||
fun = "plot_sankey",
|
||||
descr = "Sankey plot",
|
||||
note = "A way of visualising change between groups",
|
||||
primary.type = c("dichotomous", "ordinal", "categorical"),
|
||||
secondary.type = c("dichotomous", "ordinal", "categorical"),
|
||||
primary.type = c("dichotomous", "ordinal" ,"categorical"),
|
||||
secondary.type = c("dichotomous", "ordinal" ,"categorical"),
|
||||
secondary.multi = FALSE,
|
||||
secondary.extra = NULL,
|
||||
tertiary.type = c("dichotomous", "ordinal", "categorical")
|
||||
tertiary.type = c("dichotomous", "ordinal" ,"categorical")
|
||||
),
|
||||
plot_scatter = list(
|
||||
fun = "plot_scatter",
|
||||
descr = "Scatter plot",
|
||||
note = "A classic way of showing the association between to variables",
|
||||
primary.type = c("datatime", "continuous"),
|
||||
secondary.type = c("datatime", "continuous", "ordinal", "categorical"),
|
||||
primary.type = c("datatime","continuous"),
|
||||
secondary.type = c("datatime","continuous", "ordinal" ,"categorical"),
|
||||
secondary.multi = FALSE,
|
||||
tertiary.type = c("dichotomous", "ordinal", "categorical"),
|
||||
tertiary.type = c("dichotomous", "ordinal" ,"categorical"),
|
||||
secondary.extra = NULL
|
||||
),
|
||||
plot_box = list(
|
||||
fun = "plot_box",
|
||||
descr = "Box plot",
|
||||
note = "A classic way to plot data distribution by groups",
|
||||
primary.type = c("datatime", "continuous", "dichotomous", "ordinal", "categorical"),
|
||||
secondary.type = c("dichotomous", "ordinal", "categorical"),
|
||||
primary.type = c("datatime","continuous", "dichotomous", "ordinal" ,"categorical"),
|
||||
secondary.type = c("dichotomous", "ordinal" ,"categorical"),
|
||||
secondary.multi = FALSE,
|
||||
tertiary.type = c("dichotomous", "ordinal", "categorical"),
|
||||
tertiary.type = c("dichotomous", "ordinal" ,"categorical"),
|
||||
secondary.extra = "none"
|
||||
),
|
||||
plot_euler = list(
|
||||
|
|
@ -1611,7 +1645,7 @@ supported_plots <- function() {
|
|||
secondary.type = "dichotomous",
|
||||
secondary.multi = TRUE,
|
||||
secondary.max = 4,
|
||||
tertiary.type = c("dichotomous", "ordinal", "categorical"),
|
||||
tertiary.type = c("dichotomous", "ordinal" ,"categorical"),
|
||||
secondary.extra = NULL
|
||||
)
|
||||
)
|
||||
|
|
@ -1690,9 +1724,9 @@ get_plot_options <- function(data) {
|
|||
#' Wrapper to create plot based on provided type
|
||||
#'
|
||||
#' @param data data.frame
|
||||
#' @param pri primary variable
|
||||
#' @param sec secondary variable
|
||||
#' @param ter tertiary variable
|
||||
#' @param x primary variable
|
||||
#' @param y secondary variable
|
||||
#' @param z tertiary variable
|
||||
#' @param type plot type (derived from possible_plots() and matches custom function)
|
||||
#' @param ... ignored for now
|
||||
#'
|
||||
|
|
@ -1702,36 +1736,20 @@ get_plot_options <- function(data) {
|
|||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes()
|
||||
create_plot <- function(data, type, pri, sec, ter = NULL, ...) {
|
||||
if (!is.null(sec)) {
|
||||
if (!any(sec %in% names(data))) {
|
||||
sec <- NULL
|
||||
}
|
||||
#' create_plot(mtcars, "plot_violin", "mpg", "cyl")
|
||||
create_plot <- function(data, type, x, y, z = NULL, ...) {
|
||||
if (!any(y %in% names(data))) {
|
||||
y <- NULL
|
||||
}
|
||||
|
||||
if (!is.null(ter)) {
|
||||
if (!ter %in% names(data)) {
|
||||
ter <- NULL
|
||||
}
|
||||
if (!z %in% names(data)) {
|
||||
z <- NULL
|
||||
}
|
||||
|
||||
parameters <- list(
|
||||
pri = pri,
|
||||
sec = sec,
|
||||
ter = ter,
|
||||
...
|
||||
)
|
||||
|
||||
out <- do.call(
|
||||
do.call(
|
||||
type,
|
||||
modifyList(parameters,list(data=data))
|
||||
list(data, x, y, z, ...)
|
||||
)
|
||||
|
||||
code <- rlang::call2(type,!!!parameters,.ns = "FreesearchR")
|
||||
|
||||
attr(out,"code") <- code
|
||||
out
|
||||
}
|
||||
|
||||
#' Print label, and if missing print variable name
|
||||
|
|
@ -1781,8 +1799,8 @@ get_label <- function(data, var = NULL) {
|
|||
#'
|
||||
#' @examples
|
||||
#' "Lorem ipsum... you know the routine" |> line_break()
|
||||
#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE)
|
||||
line_break <- function(data, lineLength = 20, force = FALSE) {
|
||||
#' paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(fixed = TRUE)
|
||||
line_break <- function(data, lineLength = 20, fixed = FALSE) {
|
||||
if (isTRUE(force)) {
|
||||
gsub(paste0("(.{1,", lineLength, "})(\\s|[[:alnum:]])"), "\\1\n", data)
|
||||
} else {
|
||||
|
|
@ -1813,7 +1831,7 @@ wrap_plot_list <- function(data, tag_levels = NULL) {
|
|||
.x
|
||||
}
|
||||
})() |>
|
||||
align_axes() |>
|
||||
allign_axes() |>
|
||||
patchwork::wrap_plots(guides = "collect", axes = "collect", axis_titles = "collect")
|
||||
if (!is.null(tag_levels)) {
|
||||
out <- out + patchwork::plot_annotation(tag_levels = tag_levels)
|
||||
|
|
@ -1828,21 +1846,19 @@ wrap_plot_list <- function(data, tag_levels = NULL) {
|
|||
}
|
||||
|
||||
|
||||
#' Aligns axes between plots
|
||||
#' Alligns axes between plots
|
||||
#'
|
||||
#' @param ... ggplot2 objects or list of ggplot2 objects
|
||||
#'
|
||||
#' @returns list of ggplot2 objects
|
||||
#' @export
|
||||
#'
|
||||
align_axes <- function(...) {
|
||||
allign_axes <- function(...) {
|
||||
# https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object
|
||||
# https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150
|
||||
if (ggplot2::is.ggplot(..1)) {
|
||||
## Assumes list of ggplots
|
||||
p <- list(...)
|
||||
} else if (is.list(..1)) {
|
||||
## Assumes list with list of ggplots
|
||||
p <- ..1
|
||||
} else {
|
||||
cli::cli_abort("Can only align {.cls ggplot} objects or a list of them")
|
||||
|
|
@ -2197,8 +2213,8 @@ overview_vars <- function(data) {
|
|||
data <- as.data.frame(data)
|
||||
|
||||
dplyr::tibble(
|
||||
icon = data_type(data),
|
||||
type = icon,
|
||||
class = get_classes(data),
|
||||
type = data_type(data),
|
||||
name = names(data),
|
||||
n_missing = unname(colSums(is.na(data))),
|
||||
p_complete = 1 - n_missing / nrow(data),
|
||||
|
|
@ -2230,7 +2246,7 @@ create_overview_datagrid <- function(data,...) {
|
|||
|
||||
std_names <- c(
|
||||
"Name" = "name",
|
||||
"Icon" = "icon",
|
||||
"Class" = "class",
|
||||
"Type" = "type",
|
||||
"Missings" = "n_missing",
|
||||
"Complete" = "p_complete",
|
||||
|
|
@ -2268,7 +2284,7 @@ create_overview_datagrid <- function(data,...) {
|
|||
|
||||
grid <- toastui::grid_columns(
|
||||
grid = grid,
|
||||
columns = "icon",
|
||||
columns = "class",
|
||||
header = " ",
|
||||
align = "center",sortable = FALSE,
|
||||
width = 40
|
||||
|
|
@ -2276,8 +2292,7 @@ create_overview_datagrid <- function(data,...) {
|
|||
|
||||
grid <- add_class_icon(
|
||||
grid = grid,
|
||||
column = "icon",
|
||||
fun = type_icons
|
||||
column = "class"
|
||||
)
|
||||
|
||||
grid <- toastui::grid_format(
|
||||
|
|
@ -2314,41 +2329,14 @@ create_overview_datagrid <- function(data,...) {
|
|||
#' overview_vars() |>
|
||||
#' toastui::datagrid() |>
|
||||
#' add_class_icon()
|
||||
add_class_icon <- function(grid, column = "class", fun=class_icons) {
|
||||
add_class_icon <- function(grid, column = "class") {
|
||||
out <- toastui::grid_format(
|
||||
grid = grid,
|
||||
column = column,
|
||||
formatter = function(value) {
|
||||
lapply(
|
||||
X = value,
|
||||
FUN = fun
|
||||
)
|
||||
}
|
||||
)
|
||||
|
||||
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 {
|
||||
FUN = function(x) {
|
||||
if (identical(x, "numeric")) {
|
||||
shiny::icon("calculator")
|
||||
} else if (identical(x, "factor")) {
|
||||
|
|
@ -2365,41 +2353,18 @@ class_icons <- function(x) {
|
|||
shiny::icon("clock")
|
||||
} else {
|
||||
shiny::icon("table")
|
||||
}}
|
||||
}
|
||||
}
|
||||
}
|
||||
)
|
||||
}
|
||||
)
|
||||
|
||||
#' Get data type icons
|
||||
#'
|
||||
#' @param x character vector of data classes
|
||||
#'
|
||||
#' @returns
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' "ordinal" |> type_icons()
|
||||
#' default_parsing(mtcars) |> sapply(data_type) |> type_icons()
|
||||
type_icons <- function(x) {
|
||||
if (length(x)>1){
|
||||
sapply(x,class_icons)
|
||||
} else {
|
||||
if (identical(x, "continuous")) {
|
||||
shiny::icon("calculator")
|
||||
} else if (identical(x, "categorical")) {
|
||||
shiny::icon("chart-simple")
|
||||
} else if (identical(x, "ordinal")) {
|
||||
shiny::icon("arrow-down-1-9")
|
||||
} else if (identical(x, "text")) {
|
||||
shiny::icon("arrow-down-a-z")
|
||||
} else if (identical(x, "dichotomous")) {
|
||||
shiny::icon("toggle-off")
|
||||
} else if (identical(x,"datetime")) {
|
||||
shiny::icon("calendar-days")
|
||||
} else if (identical(x,"id")) {
|
||||
shiny::icon("id-card")
|
||||
} else {
|
||||
shiny::icon("table")
|
||||
}
|
||||
}
|
||||
toastui::grid_columns(
|
||||
grid = out,
|
||||
header = NULL,
|
||||
columns = column,
|
||||
width = 60
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -2766,7 +2731,7 @@ data_description <- function(data, data_text = "Data") {
|
|||
p_complete <- n_complete / n
|
||||
|
||||
sprintf(
|
||||
"%s has %s observations and %s variables, with %s (%s%%) complete cases.",
|
||||
i18n("%s has %s observations and %s variables, with %s (%s%%) complete cases."),
|
||||
data_text,
|
||||
n,
|
||||
n_var,
|
||||
|
|
@ -3668,13 +3633,13 @@ launch_FreesearchR <- function(...){
|
|||
#' @name data-plots
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> plot_box(pri = "mpg", sec = "cyl", ter = "gear")
|
||||
#' mtcars |> plot_box(x = "mpg", y = "cyl", z = "gear")
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' plot_box(pri = "mpg", sec = "cyl", ter = "gear")
|
||||
plot_box <- function(data, pri, sec, ter = NULL) {
|
||||
if (!is.null(ter)) {
|
||||
ds <- split(data, data[ter])
|
||||
#' plot_box(x = "mpg", y = "cyl", z = "gear")
|
||||
plot_box <- function(data, x, y, z = NULL) {
|
||||
if (!is.null(z)) {
|
||||
ds <- split(data, data[z])
|
||||
} else {
|
||||
ds <- list(data)
|
||||
}
|
||||
|
|
@ -3682,12 +3647,13 @@ plot_box <- function(data, pri, sec, ter = NULL) {
|
|||
out <- lapply(ds, \(.ds){
|
||||
plot_box_single(
|
||||
data = .ds,
|
||||
pri = pri,
|
||||
sec = sec
|
||||
x = x,
|
||||
y = y
|
||||
)
|
||||
})
|
||||
|
||||
wrap_plot_list(out)
|
||||
# patchwork::wrap_plots(out,guides = "collect")
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -3702,18 +3668,18 @@ plot_box <- function(data, pri, sec, ter = NULL) {
|
|||
#'
|
||||
#' @examples
|
||||
#' mtcars |> plot_box_single("mpg","cyl")
|
||||
plot_box_single <- function(data, pri, sec=NULL, seed = 2103) {
|
||||
plot_box_single <- function(data, x, y=NULL, seed = 2103) {
|
||||
set.seed(seed)
|
||||
|
||||
if (is.null(sec)) {
|
||||
sec <- "All"
|
||||
data[[y]] <- sec
|
||||
if (is.null(y)) {
|
||||
y <- "All"
|
||||
data[[y]] <- y
|
||||
}
|
||||
|
||||
discrete <- !data_type(data[[sec]]) %in% "continuous"
|
||||
discrete <- !data_type(data[[y]]) %in% "continuous"
|
||||
|
||||
data |>
|
||||
ggplot2::ggplot(ggplot2::aes(x = !!dplyr::sym(pri), y = !!dplyr::sym(sec), fill = !!dplyr::sym(sec), group = !!dplyr::sym(sec))) +
|
||||
ggplot2::ggplot(ggplot2::aes(x = !!dplyr::sym(x), y = !!dplyr::sym(y), fill = !!dplyr::sym(y), group = !!dplyr::sym(y))) +
|
||||
ggplot2::geom_boxplot(linewidth = 1.8, outliers = FALSE) +
|
||||
## THis could be optional in future
|
||||
ggplot2::geom_jitter(color = "black", size = 2, alpha = 0.9, width = 0.1, height = .5) +
|
||||
|
|
@ -3823,16 +3789,16 @@ ggeulerr <- function(
|
|||
#' D = sample(c(TRUE, FALSE, FALSE, FALSE), 50, TRUE)
|
||||
#' ) |> plot_euler("A", c("B", "C"), "D", seed = 4)
|
||||
#' mtcars |> plot_euler("vs", "am", seed = 1)
|
||||
plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) {
|
||||
plot_euler <- function(data, x, y, z = NULL, seed = 2103) {
|
||||
set.seed(seed = seed)
|
||||
if (!is.null(ter)) {
|
||||
ds <- split(data, data[ter])
|
||||
if (!is.null(z)) {
|
||||
ds <- split(data, data[z])
|
||||
} else {
|
||||
ds <- list(data)
|
||||
}
|
||||
|
||||
out <- lapply(ds, \(.x){
|
||||
.x[c(pri, sec)] |>
|
||||
.x[c(x, y)] |>
|
||||
as.data.frame() |>
|
||||
plot_euler_single()
|
||||
})
|
||||
|
|
@ -3842,6 +3808,7 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) {
|
|||
# patchwork::wrap_plots(out, guides = "collect")
|
||||
}
|
||||
|
||||
?withCallingHandlers()
|
||||
#' Easily plot single euler diagrams
|
||||
#'
|
||||
#' @returns ggplot2 object
|
||||
|
|
@ -3887,10 +3854,10 @@ plot_euler_single <- function(data) {
|
|||
#' @name data-plots
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> plot_hbars(pri = "carb", sec = "cyl")
|
||||
#' mtcars |> plot_hbars(pri = "carb", sec = NULL)
|
||||
plot_hbars <- function(data, pri, sec, ter = NULL) {
|
||||
out <- vertical_stacked_bars(data = data, score = pri, group = sec, strata = ter)
|
||||
#' mtcars |> plot_hbars(x = "carb", y = "cyl")
|
||||
#' mtcars |> plot_hbars(x = "carb", y = NULL)
|
||||
plot_hbars <- function(data, x, y, z = NULL) {
|
||||
out <- vertical_stacked_bars(data = data, score = x, group = y, strata = z)
|
||||
|
||||
out
|
||||
}
|
||||
|
|
@ -4031,42 +3998,42 @@ plot_ridge <- function(data, x, y, z = NULL, ...) {
|
|||
#' last = sample(c(TRUE, FALSE, FALSE), 100, TRUE)
|
||||
#' ) |>
|
||||
#' sankey_ready("first", "last")
|
||||
sankey_ready <- function(data, pri, sec, numbers = "count", ...) {
|
||||
sankey_ready <- function(data, x, y, numbers = "count", ...) {
|
||||
## TODO: Ensure ordering x and y
|
||||
|
||||
## Ensure all are factors
|
||||
data[c(pri, sec)] <- data[c(pri, sec)] |>
|
||||
data[c(x, y)] <- data[c(x, y)] |>
|
||||
dplyr::mutate(dplyr::across(!dplyr::where(is.factor), forcats::as_factor))
|
||||
|
||||
out <- dplyr::count(data, !!dplyr::sym(pri), !!dplyr::sym(sec))
|
||||
out <- dplyr::count(data, !!dplyr::sym(x), !!dplyr::sym(y))
|
||||
|
||||
out <- out |>
|
||||
dplyr::group_by(!!dplyr::sym(pri)) |>
|
||||
dplyr::group_by(!!dplyr::sym(x)) |>
|
||||
dplyr::mutate(gx.sum = sum(n)) |>
|
||||
dplyr::ungroup() |>
|
||||
dplyr::group_by(!!dplyr::sym(sec)) |>
|
||||
dplyr::group_by(!!dplyr::sym(y)) |>
|
||||
dplyr::mutate(gy.sum = sum(n)) |>
|
||||
dplyr::ungroup()
|
||||
|
||||
if (numbers == "count") {
|
||||
out <- out |> dplyr::mutate(
|
||||
lx = factor(paste0(!!dplyr::sym(pri), "\n(n=", gx.sum, ")")),
|
||||
ly = factor(paste0(!!dplyr::sym(sec), "\n(n=", gy.sum, ")"))
|
||||
lx = factor(paste0(!!dplyr::sym(x), "\n(n=", gx.sum, ")")),
|
||||
ly = factor(paste0(!!dplyr::sym(y), "\n(n=", gy.sum, ")"))
|
||||
)
|
||||
} else if (numbers == "percentage") {
|
||||
out <- out |> dplyr::mutate(
|
||||
lx = factor(paste0(!!dplyr::sym(pri), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)")),
|
||||
ly = factor(paste0(!!dplyr::sym(sec), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)"))
|
||||
lx = factor(paste0(!!dplyr::sym(x), "\n(", round((gx.sum / sum(n)) * 100, 1), "%)")),
|
||||
ly = factor(paste0(!!dplyr::sym(y), "\n(", round((gy.sum / sum(n)) * 100, 1), "%)"))
|
||||
)
|
||||
}
|
||||
|
||||
if (is.factor(data[[pri]])) {
|
||||
index <- match(levels(data[[pri]]), str_remove_last(levels(out$lx), "\n"))
|
||||
if (is.factor(data[[x]])) {
|
||||
index <- match(levels(data[[x]]), str_remove_last(levels(out$lx), "\n"))
|
||||
out$lx <- factor(out$lx, levels = levels(out$lx)[index])
|
||||
}
|
||||
|
||||
if (is.factor(data[[sec]])) {
|
||||
index <- match(levels(data[[sec]]), str_remove_last(levels(out$ly), "\n"))
|
||||
if (is.factor(data[[y]])) {
|
||||
index <- match(levels(data[[y]]), str_remove_last(levels(out$ly), "\n"))
|
||||
out$ly <- factor(out$ly, levels = levels(out$ly)[index])
|
||||
}
|
||||
|
||||
|
|
@ -4091,15 +4058,15 @@ str_remove_last <- function(data, pattern = "\n") {
|
|||
#' ds |> plot_sankey("first", "last")
|
||||
#' ds |> plot_sankey("first", "last", color.group = "y")
|
||||
#' ds |> plot_sankey("first", "last", z = "g", color.group = "y")
|
||||
plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "x", colors = NULL) {
|
||||
if (!is.null(ter)) {
|
||||
ds <- split(data, data[ter])
|
||||
plot_sankey <- function(data, x, y, z = NULL, color.group = "x", colors = NULL) {
|
||||
if (!is.null(z)) {
|
||||
ds <- split(data, data[z])
|
||||
} else {
|
||||
ds <- list(data)
|
||||
}
|
||||
|
||||
out <- lapply(ds, \(.ds){
|
||||
plot_sankey_single(.ds, x = pri, y = sec, color.group = color.group, colors = colors)
|
||||
plot_sankey_single(.ds, x = x, y = y, color.group = color.group, colors = colors)
|
||||
})
|
||||
|
||||
patchwork::wrap_plots(out)
|
||||
|
|
@ -4128,10 +4095,10 @@ default_theme <- function() {
|
|||
#' first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)),
|
||||
#' last = sample(c(TRUE, FALSE, FALSE), 100, TRUE)
|
||||
#' ) |>
|
||||
#' plot_sankey_single("first", "last", color.group = "pri")
|
||||
plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), colors = NULL, ...) {
|
||||
#' plot_sankey_single("first", "last", color.group = "x")
|
||||
plot_sankey_single <- function(data, x, y, color.group = c("x", "y"), colors = NULL, ...) {
|
||||
color.group <- match.arg(color.group)
|
||||
data <- data |> sankey_ready(pri = pri, sec = sec, ...)
|
||||
data <- data |> sankey_ready(x = x, y = y, ...)
|
||||
|
||||
library(ggalluvial)
|
||||
|
||||
|
|
@ -4139,13 +4106,13 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
|
|||
box.color <- "#1E4B66"
|
||||
|
||||
if (is.null(colors)) {
|
||||
if (color.group == "sec") {
|
||||
main.colors <- viridisLite::viridis(n = length(levels(data[[sec]])))
|
||||
secondary.colors <- rep(na.color, length(levels(data[[pri]])))
|
||||
if (color.group == "y") {
|
||||
main.colors <- viridisLite::viridis(n = length(levels(data[[y]])))
|
||||
secondary.colors <- rep(na.color, length(levels(data[[x]])))
|
||||
label.colors <- Reduce(c, lapply(list(secondary.colors, rev(main.colors)), contrast_text))
|
||||
} else {
|
||||
main.colors <- viridisLite::viridis(n = length(levels(data[[pri]])))
|
||||
secondary.colors <- rep(na.color, length(levels(data[[sec]])))
|
||||
main.colors <- viridisLite::viridis(n = length(levels(data[[x]])))
|
||||
secondary.colors <- rep(na.color, length(levels(data[[y]])))
|
||||
label.colors <- Reduce(c, lapply(list(rev(main.colors), secondary.colors), contrast_text))
|
||||
}
|
||||
colors <- c(na.color, main.colors, secondary.colors)
|
||||
|
|
@ -4153,33 +4120,33 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
|
|||
label.colors <- contrast_text(colors)
|
||||
}
|
||||
|
||||
group_labels <- c(get_label(data, pri), get_label(data, sec)) |>
|
||||
group_labels <- c(get_label(data, x), get_label(data, y)) |>
|
||||
sapply(line_break) |>
|
||||
unname()
|
||||
|
||||
p <- ggplot2::ggplot(data, ggplot2::aes(y = n, axis1 = lx, axis2 = ly))
|
||||
|
||||
if (color.group == "sec") {
|
||||
if (color.group == "y") {
|
||||
p <- p +
|
||||
ggalluvial::geom_alluvium(
|
||||
ggplot2::aes(fill = !!dplyr::sym(sec), color = !!dplyr::sym(sec)),
|
||||
ggplot2::aes(fill = !!dplyr::sym(y), color = !!dplyr::sym(y)),
|
||||
width = 1 / 16,
|
||||
alpha = .8,
|
||||
knot.pos = 0.4,
|
||||
curve_type = "sigmoid"
|
||||
) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(sec)),
|
||||
) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(y)),
|
||||
size = 2,
|
||||
width = 1 / 3.4
|
||||
)
|
||||
} else {
|
||||
p <- p +
|
||||
ggalluvial::geom_alluvium(
|
||||
ggplot2::aes(fill = !!dplyr::sym(pri), color = !!dplyr::sym(pri)),
|
||||
ggplot2::aes(fill = !!dplyr::sym(x), color = !!dplyr::sym(x)),
|
||||
width = 1 / 16,
|
||||
alpha = .8,
|
||||
knot.pos = 0.4,
|
||||
curve_type = "sigmoid"
|
||||
) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(pri)),
|
||||
) + ggalluvial::geom_stratum(ggplot2::aes(fill = !!dplyr::sym(x)),
|
||||
size = 2,
|
||||
width = 1 / 3.4
|
||||
)
|
||||
|
|
@ -4228,24 +4195,20 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
|
|||
#' @name data-plots
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> plot_scatter(pri = "mpg", sec = "wt")
|
||||
plot_scatter <- function(data, pri, sec, ter = NULL) {
|
||||
if (is.null(ter)) {
|
||||
#' mtcars |> plot_scatter(x = "mpg", y = "wt")
|
||||
plot_scatter <- function(data, x, y, z = NULL) {
|
||||
if (is.null(z)) {
|
||||
rempsyc::nice_scatter(
|
||||
data = data,
|
||||
predictor = sec,
|
||||
response = pri,
|
||||
xtitle = get_label(data, var = sec),
|
||||
ytitle = get_label(data, var = pri)
|
||||
predictor = y,
|
||||
response = x, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x)
|
||||
)
|
||||
} else {
|
||||
rempsyc::nice_scatter(
|
||||
data = data,
|
||||
predictor = sec,
|
||||
response = pri,
|
||||
group = ter,
|
||||
xtitle = get_label(data, var = sec),
|
||||
ytitle = get_label(data, var = pri)
|
||||
predictor = y,
|
||||
response = x,
|
||||
group = z, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x)
|
||||
)
|
||||
}
|
||||
}
|
||||
|
|
@ -4263,10 +4226,10 @@ plot_scatter <- function(data, pri, sec, ter = NULL) {
|
|||
#' @name data-plots
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear")
|
||||
plot_violin <- function(data, pri, sec, ter = NULL) {
|
||||
if (!is.null(ter)) {
|
||||
ds <- split(data, data[ter])
|
||||
#' mtcars |> plot_violin(x = "mpg", y = "cyl", z = "gear")
|
||||
plot_violin <- function(data, x, y, z = NULL) {
|
||||
if (!is.null(z)) {
|
||||
ds <- split(data, data[z])
|
||||
} else {
|
||||
ds <- list(data)
|
||||
}
|
||||
|
|
@ -4274,10 +4237,8 @@ plot_violin <- function(data, pri, sec, ter = NULL) {
|
|||
out <- lapply(ds, \(.ds){
|
||||
rempsyc::nice_violin(
|
||||
data = .ds,
|
||||
group = sec,
|
||||
response = pri,
|
||||
xtitle = get_label(data, var = sec),
|
||||
ytitle = get_label(data, var = pri)
|
||||
group = y,
|
||||
response = x, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x)
|
||||
)
|
||||
})
|
||||
|
||||
|
|
|
|||
|
|
@ -5,6 +5,6 @@ account: agdamsbo
|
|||
server: shinyapps.io
|
||||
hostUrl: https://api.shinyapps.io/v1
|
||||
appId: 13611288
|
||||
bundleId: 10119038
|
||||
bundleId: 10111887
|
||||
url: https://agdamsbo.shinyapps.io/freesearcheR/
|
||||
version: 1
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
\alias{add_class_icon}
|
||||
\title{Convert class grid column to icon}
|
||||
\usage{
|
||||
add_class_icon(grid, column = "class", fun = class_icons)
|
||||
add_class_icon(grid, column = "class")
|
||||
}
|
||||
\arguments{
|
||||
\item{grid}{grid}
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/data_plots.R
|
||||
\name{align_axes}
|
||||
\alias{align_axes}
|
||||
\title{Aligns axes between plots}
|
||||
\name{allign_axes}
|
||||
\alias{allign_axes}
|
||||
\title{Alligns axes between plots}
|
||||
\usage{
|
||||
align_axes(...)
|
||||
allign_axes(...)
|
||||
}
|
||||
\arguments{
|
||||
\item{...}{ggplot2 objects or list of ggplot2 objects}
|
||||
|
|
@ -13,5 +13,5 @@ align_axes(...)
|
|||
list of ggplot2 objects
|
||||
}
|
||||
\description{
|
||||
Aligns axes between plots
|
||||
Alligns axes between plots
|
||||
}
|
||||
|
|
@ -15,7 +15,3 @@ list
|
|||
\description{
|
||||
Idea from the answer: https://stackoverflow.com/a/62979238
|
||||
}
|
||||
\examples{
|
||||
argsstring2list("A=1:5,b=2:4")
|
||||
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,21 +0,0 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/data-summary.R
|
||||
\name{class_icons}
|
||||
\alias{class_icons}
|
||||
\title{Get data class icons}
|
||||
\usage{
|
||||
class_icons(x)
|
||||
}
|
||||
\arguments{
|
||||
\item{x}{character vector of data classes}
|
||||
}
|
||||
\value{
|
||||
list
|
||||
}
|
||||
\description{
|
||||
Get data class icons
|
||||
}
|
||||
\examples{
|
||||
"numeric" |> class_icons()|> str()
|
||||
mtcars |> sapply(class) |> class_icons() |> str()
|
||||
}
|
||||
|
|
@ -32,5 +32,4 @@ Create a baseline table
|
|||
}
|
||||
\examples{
|
||||
mtcars |> create_baseline(by.var = "gear", add.p = "yes" == "yes")
|
||||
create_baseline(default_parsing(mtcars), by.var = "am", add.p = FALSE, add.overall = FALSE, theme = "lancet")
|
||||
}
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@
|
|||
\alias{cut_variable_ui}
|
||||
\alias{cut_variable_server}
|
||||
\alias{modal_cut_variable}
|
||||
\alias{winbox_cut_variable}
|
||||
\title{Module to Convert Numeric to Factor}
|
||||
\usage{
|
||||
cut_variable_ui(id)
|
||||
|
|
@ -18,6 +19,13 @@ modal_cut_variable(
|
|||
size = "l",
|
||||
footer = NULL
|
||||
)
|
||||
|
||||
winbox_cut_variable(
|
||||
id,
|
||||
title = i18n("Convert Numeric to Factor"),
|
||||
options = shinyWidgets::wbOptions(),
|
||||
controls = shinyWidgets::wbControls()
|
||||
)
|
||||
}
|
||||
\arguments{
|
||||
\item{id}{Module ID.}
|
||||
|
|
@ -39,6 +47,10 @@ pass \code{\link[bslib:bs_theme]{bslib::bs_theme()}} to the \code{theme} argumen
|
|||
like \code{\link[shiny:fluidPage]{fluidPage()}}).}
|
||||
|
||||
\item{footer}{UI for footer. Use \code{NULL} for no footer.}
|
||||
|
||||
\item{options}{List of options, see \code{\link[shinyWidgets:wbOptions]{wbOptions()}}.}
|
||||
|
||||
\item{controls}{List of controls, see \code{\link[shinyWidgets:wbControls]{wbControls()}}.}
|
||||
}
|
||||
\value{
|
||||
A \code{\link[shiny:reactive]{shiny::reactive()}} function returning the data.
|
||||
|
|
|
|||
|
|
@ -20,23 +20,23 @@ data_visuals_ui(id, tab_title = "Plots", ...)
|
|||
|
||||
data_visuals_server(id, data, ...)
|
||||
|
||||
create_plot(data, type, pri, sec, ter = NULL, ...)
|
||||
create_plot(data, type, x, y, z = NULL, ...)
|
||||
|
||||
plot_box(data, pri, sec, ter = NULL)
|
||||
plot_box(data, x, y, z = NULL)
|
||||
|
||||
plot_box_single(data, pri, sec = NULL, seed = 2103)
|
||||
plot_box_single(data, x, y = NULL, seed = 2103)
|
||||
|
||||
plot_hbars(data, pri, sec, ter = NULL)
|
||||
plot_hbars(data, x, y, z = NULL)
|
||||
|
||||
plot_ridge(data, x, y, z = NULL, ...)
|
||||
|
||||
sankey_ready(data, pri, sec, numbers = "count", ...)
|
||||
sankey_ready(data, x, y, numbers = "count", ...)
|
||||
|
||||
plot_sankey(data, pri, sec, ter = NULL, color.group = "x", colors = NULL)
|
||||
plot_sankey(data, x, y, z = NULL, color.group = "x", colors = NULL)
|
||||
|
||||
plot_scatter(data, pri, sec, ter = NULL)
|
||||
plot_scatter(data, x, y, z = NULL)
|
||||
|
||||
plot_violin(data, pri, sec, ter = NULL)
|
||||
plot_violin(data, x, y, z = NULL)
|
||||
}
|
||||
\arguments{
|
||||
\item{id}{Module id. (Use 'ns("id")')}
|
||||
|
|
@ -47,11 +47,11 @@ plot_violin(data, pri, sec, ter = NULL)
|
|||
|
||||
\item{type}{plot type (derived from possible_plots() and matches custom function)}
|
||||
|
||||
\item{pri}{primary variable}
|
||||
\item{x}{primary variable}
|
||||
|
||||
\item{sec}{secondary variable}
|
||||
\item{y}{secondary variable}
|
||||
|
||||
\item{ter}{tertiary variable}
|
||||
\item{z}{tertiary variable}
|
||||
}
|
||||
\value{
|
||||
Shiny ui module
|
||||
|
|
@ -98,14 +98,14 @@ Beautiful violin plot
|
|||
Beatiful violin plot
|
||||
}
|
||||
\examples{
|
||||
create_plot(mtcars, "plot_violin", "mpg", "cyl") |> attributes()
|
||||
mtcars |> plot_box(pri = "mpg", sec = "cyl", ter = "gear")
|
||||
create_plot(mtcars, "plot_violin", "mpg", "cyl")
|
||||
mtcars |> plot_box(x = "mpg", y = "cyl", z = "gear")
|
||||
mtcars |>
|
||||
default_parsing() |>
|
||||
plot_box(pri = "mpg", sec = "cyl", ter = "gear")
|
||||
plot_box(x = "mpg", y = "cyl", z = "gear")
|
||||
mtcars |> plot_box_single("mpg","cyl")
|
||||
mtcars |> plot_hbars(pri = "carb", sec = "cyl")
|
||||
mtcars |> plot_hbars(pri = "carb", sec = NULL)
|
||||
mtcars |> plot_hbars(x = "carb", y = "cyl")
|
||||
mtcars |> plot_hbars(x = "carb", y = NULL)
|
||||
mtcars |>
|
||||
default_parsing() |>
|
||||
plot_ridge(x = "mpg", y = "cyl")
|
||||
|
|
@ -123,6 +123,6 @@ ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_fac
|
|||
ds |> plot_sankey("first", "last")
|
||||
ds |> plot_sankey("first", "last", color.group = "y")
|
||||
ds |> plot_sankey("first", "last", z = "g", color.group = "y")
|
||||
mtcars |> plot_scatter(pri = "mpg", sec = "wt")
|
||||
mtcars |> plot_violin(pri = "mpg", sec = "cyl", ter = "gear")
|
||||
mtcars |> plot_scatter(x = "mpg", y = "wt")
|
||||
mtcars |> plot_violin(x = "mpg", y = "cyl", z = "gear")
|
||||
}
|
||||
|
|
|
|||
|
|
@ -18,13 +18,8 @@ data.frame
|
|||
Filter function to filter data set by variable type
|
||||
}
|
||||
\examples{
|
||||
default_parsing(mtcars) |>
|
||||
data_type_filter(type = c("categorical", "continuous")) |>
|
||||
attributes()
|
||||
default_parsing(mtcars) |>
|
||||
data_type_filter(type = NULL) |>
|
||||
attributes()
|
||||
default_parsing(mtcars) |> data_type_filter(type=c("categorical","continuous")) |> attributes()
|
||||
\dontrun{
|
||||
default_parsing(mtcars) |> data_type_filter(type = c("test", "categorical", "continuous"))
|
||||
default_parsing(mtcars) |> data_type_filter(type=c("test","categorical","continuous"))
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
) |>
|
||||
|
|
|
|||
|
|
@ -17,6 +17,3 @@ data.frame
|
|||
\description{
|
||||
Factorize variables in data.frame
|
||||
}
|
||||
\examples{
|
||||
factorize(mtcars,names(mtcars))
|
||||
}
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
\alias{line_break}
|
||||
\title{Line breaking at given number of characters for nicely plotting labels}
|
||||
\usage{
|
||||
line_break(data, lineLength = 20, force = FALSE)
|
||||
line_break(data, lineLength = 20, fixed = FALSE)
|
||||
}
|
||||
\arguments{
|
||||
\item{data}{string}
|
||||
|
|
@ -22,5 +22,5 @@ Line breaking at given number of characters for nicely plotting labels
|
|||
}
|
||||
\examples{
|
||||
"Lorem ipsum... you know the routine" |> line_break()
|
||||
paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(force = TRUE)
|
||||
paste(sample(letters[1:10], 100, TRUE), collapse = "") |> line_break(fixed = TRUE)
|
||||
}
|
||||
|
|
|
|||
|
|
@ -4,18 +4,18 @@
|
|||
\alias{plot_euler}
|
||||
\title{Easily plot euler diagrams}
|
||||
\usage{
|
||||
plot_euler(data, pri, sec, ter = NULL, seed = 2103)
|
||||
plot_euler(data, x, y, z = NULL, seed = 2103)
|
||||
}
|
||||
\arguments{
|
||||
\item{data}{data}
|
||||
|
||||
\item{seed}{seed}
|
||||
|
||||
\item{x}{name of main variable}
|
||||
|
||||
\item{y}{name of secondary variables}
|
||||
|
||||
\item{z}{grouping variable}
|
||||
|
||||
\item{seed}{seed}
|
||||
}
|
||||
\value{
|
||||
patchwork object
|
||||
|
|
|
|||
|
|
@ -4,14 +4,7 @@
|
|||
\alias{plot_sankey_single}
|
||||
\title{Beautiful sankey plot}
|
||||
\usage{
|
||||
plot_sankey_single(
|
||||
data,
|
||||
pri,
|
||||
sec,
|
||||
color.group = c("pri", "sec"),
|
||||
colors = NULL,
|
||||
...
|
||||
)
|
||||
plot_sankey_single(data, x, y, color.group = c("x", "y"), colors = NULL, ...)
|
||||
}
|
||||
\arguments{
|
||||
\item{color.group}{set group to colour by. "x" or "y".}
|
||||
|
|
@ -36,5 +29,5 @@ data.frame(
|
|||
first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)),
|
||||
last = sample(c(TRUE, FALSE, FALSE), 100, TRUE)
|
||||
) |>
|
||||
plot_sankey_single("first", "last", color.group = "pri")
|
||||
plot_sankey_single("first", "last", color.group = "x")
|
||||
}
|
||||
|
|
|
|||
|
|
@ -15,12 +15,3 @@ data of same class as input
|
|||
\description{
|
||||
Remove empty/NA attributes
|
||||
}
|
||||
\examples{
|
||||
ds <- mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x, label = NA, attr = "label")) |> dplyr::bind_cols()
|
||||
ds |>
|
||||
remove_empty_attr() |>
|
||||
str()
|
||||
mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x, label = NA, attr = "label")) |> remove_empty_attr() |>
|
||||
str()
|
||||
|
||||
}
|
||||
|
|
|
|||
23
man/remove_na_attr.Rd
Normal file
23
man/remove_na_attr.Rd
Normal file
|
|
@ -0,0 +1,23 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/helpers.R
|
||||
\name{remove_na_attr}
|
||||
\alias{remove_na_attr}
|
||||
\title{Remove NA labels}
|
||||
\usage{
|
||||
remove_na_attr(data, attr = "label")
|
||||
}
|
||||
\arguments{
|
||||
\item{data}{data}
|
||||
}
|
||||
\value{
|
||||
data.frame
|
||||
}
|
||||
\description{
|
||||
Remove NA labels
|
||||
}
|
||||
\examples{
|
||||
ds <- mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x, label = NA, attr = "label"))
|
||||
ds |>
|
||||
remove_na_attr() |>
|
||||
str()
|
||||
}
|
||||
|
|
@ -2,7 +2,7 @@
|
|||
% Please edit documentation in R/helpers.R
|
||||
\name{remove_nested_list}
|
||||
\alias{remove_nested_list}
|
||||
\title{Very simple function to remove nested lists, like when uploading .rds}
|
||||
\title{Very simple function to remove nested lists, lik ewhen uploading .rds}
|
||||
\usage{
|
||||
remove_nested_list(data)
|
||||
}
|
||||
|
|
@ -13,7 +13,7 @@ remove_nested_list(data)
|
|||
data.frame
|
||||
}
|
||||
\description{
|
||||
Very simple function to remove nested lists, like when uploading .rds
|
||||
Very simple function to remove nested lists, lik ewhen uploading .rds
|
||||
}
|
||||
\examples{
|
||||
dplyr::tibble(a = 1:10, b = rep(list("a"), 10)) |> remove_nested_list()
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,21 +0,0 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/data-summary.R
|
||||
\name{type_icons}
|
||||
\alias{type_icons}
|
||||
\title{Get data type icons}
|
||||
\usage{
|
||||
type_icons(x)
|
||||
}
|
||||
\arguments{
|
||||
\item{x}{character vector of data classes}
|
||||
}
|
||||
\value{
|
||||
list
|
||||
}
|
||||
\description{
|
||||
Get data type icons
|
||||
}
|
||||
\examples{
|
||||
"ordinal" |> type_icons()
|
||||
default_parsing(mtcars) |> sapply(data_type) |> type_icons()
|
||||
}
|
||||
|
|
@ -8,6 +8,5 @@
|
|||
|
||||
library(testthat)
|
||||
library(FreesearchR)
|
||||
library(shiny)
|
||||
|
||||
test_check("FreesearchR")
|
||||
|
|
|
|||
|
|
@ -1,23 +0,0 @@
|
|||
# Contrasting works
|
||||
|
||||
Code
|
||||
contrast_text(colors)
|
||||
Output
|
||||
[1] "black" "white" "white" "white" "black" "white"
|
||||
|
||||
---
|
||||
|
||||
Code
|
||||
contrast_text(colors, light_text = "blue", dark_text = "grey10", method = "relative",
|
||||
threshold = 0.1)
|
||||
Output
|
||||
[1] "grey10" "blue" "grey10" "blue" "grey10" "grey10"
|
||||
|
||||
---
|
||||
|
||||
Code
|
||||
contrast_text(colors, light_text = "blue", dark_text = "grey10", method = "perceived",
|
||||
threshold = 0.7)
|
||||
Output
|
||||
[1] "grey10" "blue" "blue" "blue" "grey10" "blue"
|
||||
|
||||
|
|
@ -1,160 +0,0 @@
|
|||
# all_but works
|
||||
|
||||
Code
|
||||
all_but(1:10, c(2, 3), 11, 5)
|
||||
Output
|
||||
[1] 1 4 6 7 8 9 10
|
||||
|
||||
# subset_types works
|
||||
|
||||
Code
|
||||
subset_types(default_parsing(mtcars), "continuous")
|
||||
Output
|
||||
# A tibble: 32 x 6
|
||||
mpg disp hp drat wt qsec
|
||||
<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"
|
||||
|
||||
|
|
@ -1,532 +0,0 @@
|
|||
# getfun works
|
||||
|
||||
Code
|
||||
getfun("stats::lm")
|
||||
Output
|
||||
function (formula, data, subset, weights, na.action, method = "qr",
|
||||
model = TRUE, x = FALSE, y = FALSE, qr = TRUE, singular.ok = TRUE,
|
||||
contrasts = NULL, offset, ...)
|
||||
{
|
||||
ret.x <- x
|
||||
ret.y <- y
|
||||
cl <- match.call()
|
||||
mf <- match.call(expand.dots = FALSE)
|
||||
m <- match(c("formula", "data", "subset", "weights", "na.action",
|
||||
"offset"), names(mf), 0L)
|
||||
mf <- mf[c(1L, m)]
|
||||
mf$drop.unused.levels <- TRUE
|
||||
mf[[1L]] <- quote(stats::model.frame)
|
||||
mf <- eval(mf, parent.frame())
|
||||
if (method == "model.frame")
|
||||
return(mf)
|
||||
else if (method != "qr")
|
||||
warning(gettextf("method = '%s' is not supported. Using 'qr'",
|
||||
method), domain = NA)
|
||||
mt <- attr(mf, "terms")
|
||||
y <- model.response(mf, "numeric")
|
||||
w <- as.vector(model.weights(mf))
|
||||
if (!is.null(w) && !is.numeric(w))
|
||||
stop("'weights' must be a numeric vector")
|
||||
offset <- model.offset(mf)
|
||||
mlm <- is.matrix(y)
|
||||
ny <- if (mlm)
|
||||
nrow(y)
|
||||
else length(y)
|
||||
if (!is.null(offset)) {
|
||||
if (!mlm)
|
||||
offset <- as.vector(offset)
|
||||
if (NROW(offset) != ny)
|
||||
stop(gettextf("number of offsets is %d, should equal %d (number of observations)",
|
||||
NROW(offset), ny), domain = NA)
|
||||
}
|
||||
if (is.empty.model(mt)) {
|
||||
x <- NULL
|
||||
z <- list(coefficients = if (mlm) matrix(NA_real_, 0,
|
||||
ncol(y)) else numeric(), residuals = y, fitted.values = 0 *
|
||||
y, weights = w, rank = 0L, df.residual = if (!is.null(w)) sum(w !=
|
||||
0) else ny)
|
||||
if (!is.null(offset)) {
|
||||
z$fitted.values <- offset
|
||||
z$residuals <- y - offset
|
||||
}
|
||||
}
|
||||
else {
|
||||
x <- model.matrix(mt, mf, contrasts)
|
||||
z <- if (is.null(w))
|
||||
lm.fit(x, y, offset = offset, singular.ok = singular.ok,
|
||||
...)
|
||||
else lm.wfit(x, y, w, offset = offset, singular.ok = singular.ok,
|
||||
...)
|
||||
}
|
||||
class(z) <- c(if (mlm) "mlm", "lm")
|
||||
z$na.action <- attr(mf, "na.action")
|
||||
z$offset <- offset
|
||||
z$contrasts <- attr(x, "contrasts")
|
||||
z$xlevels <- .getXlevels(mt, mf)
|
||||
z$call <- cl
|
||||
z$terms <- mt
|
||||
if (model)
|
||||
z$model <- mf
|
||||
if (ret.x)
|
||||
z$x <- x
|
||||
if (ret.y)
|
||||
z$y <- y
|
||||
if (!qr)
|
||||
z$qr <- NULL
|
||||
z
|
||||
}
|
||||
<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
|
||||
|
||||
|
|
@ -3,26 +3,44 @@
|
|||
|
||||
test_that("Creates correct table",{
|
||||
## This is by far the easiest way to test all functions. Based on examples.
|
||||
tbl <- create_baseline(mtcars,by.var = "gear", add.p = "yes" == "yes",add.overall = TRUE, theme = "lancet")
|
||||
expect_snapshot(create_baseline(mtcars,by.var = "gear", add.p = "yes" == "yes",add.overall = TRUE, theme = "lancet"))
|
||||
expect_snapshot(create_baseline(mtcars,by.var = "none", add.p = FALSE,add.overall = FALSE, theme = "lancet"))
|
||||
expect_snapshot(create_baseline(mtcars,by.var = "test", add.p = FALSE,add.overall = FALSE, theme = "jama"))
|
||||
expect_snapshot(create_baseline(default_parsing(mtcars),by.var = "am", add.p = FALSE,add.overall = FALSE, theme = "nejm"))
|
||||
})
|
||||
|
||||
expect_equal(length(tbl),5)
|
||||
test_that("Creates table", {
|
||||
tbl <- mtcars |> baseline_table(fun.args = list(by = "gear"))
|
||||
|
||||
expect_equal(length(tbl), 5)
|
||||
|
||||
expect_equal(NROW(tbl$table_body), 19)
|
||||
|
||||
expect_equal(NCOL(tbl$table_body), 8)
|
||||
|
||||
expect_equal(names(tbl), c("table_body", "table_styling", "call_list", "cards", "inputs"))
|
||||
})
|
||||
|
||||
test_that("Creates table", {
|
||||
tbl <- mtcars |> create_baseline(by.var = "gear", add.p = "yes" == "yes")
|
||||
|
||||
expect_equal(length(tbl), 5)
|
||||
|
||||
expect_equal(NROW(tbl$table_body), 19)
|
||||
|
||||
expect_equal(NCOL(tbl$table_body), 13)
|
||||
tbl$call_list
|
||||
|
||||
expect_equal(names(tbl), c("table_body", "table_styling", "call_list", "cards", "inputs"))
|
||||
|
||||
tbl <- create_baseline(mtcars,by.var = "none", add.p = FALSE,add.overall = FALSE, theme = "lancet")
|
||||
|
||||
expect_equal(length(tbl),5)
|
||||
|
||||
tbl <- create_baseline(mtcars,by.var = "test", add.p = FALSE,add.overall = FALSE, theme = "jama")
|
||||
|
||||
expect_equal(length(tbl),5)
|
||||
|
||||
tbl <- create_baseline(default_parsing(mtcars),by.var = "am", add.p = FALSE,add.overall = FALSE, theme = "nejm")
|
||||
|
||||
expect_equal(length(tbl),5)
|
||||
})
|
||||
|
||||
test_that("Creates table", {
|
||||
tbl <- mtcars |> create_baseline(by.var = "gear", add.p = "yes" == "yes")
|
||||
|
||||
expect_equal(length(tbl), 5)
|
||||
|
||||
expect_equal(NROW(tbl$table_body), 19)
|
||||
|
||||
expect_equal(NCOL(tbl$table_body), 13)
|
||||
|
||||
expect_equal(names(tbl), c("table_body", "table_styling", "call_list", "cards", "inputs"))
|
||||
})
|
||||
|
|
|
|||
|
|
@ -1,17 +0,0 @@
|
|||
test_that("correlations module works", {
|
||||
testServer(data_correlations_server, args=list(data = mtcars,cutoff = shiny::reactive(.8)), {
|
||||
expect_equal(nchar(output$suggest), 281)
|
||||
expect_equal(class(output$correlation_plot),"list")
|
||||
expect_equal(length(output$correlation_plot),5)
|
||||
})
|
||||
|
||||
expect_snapshot(
|
||||
correlation_pairs(data = gtsummary::trial,threshold = .2)
|
||||
)
|
||||
|
||||
expect_snapshot(
|
||||
sentence_paste(letters[1:8])
|
||||
)
|
||||
|
||||
})
|
||||
|
||||
|
|
@ -1,83 +1,3 @@
|
|||
test_that("Create columnSelectInput", {
|
||||
library(shiny)
|
||||
ui <- shiny::fluidPage(
|
||||
shiny::uiOutput("x"),
|
||||
shiny::uiOutput("out")
|
||||
)
|
||||
server <- function(input, output, session) {
|
||||
library(FreesearchR)
|
||||
output$x <-
|
||||
shiny::renderUI({
|
||||
columnSelectInput(inputId = "x",selected = "mpg",label = "X",data = mtcars)
|
||||
})
|
||||
|
||||
output$out <- renderText({
|
||||
# req(input$x)
|
||||
input$x
|
||||
})
|
||||
}
|
||||
|
||||
# shinyApp(ui,server)
|
||||
|
||||
testServer(server, {
|
||||
session$setInputs(x = "cyl")
|
||||
expect_equal(output$out, "cyl")
|
||||
|
||||
session$setInputs(x = "mpg")
|
||||
expect_equal(output$out, "mpg")
|
||||
})
|
||||
|
||||
server <- function(input, output, session) {
|
||||
library(FreesearchR)
|
||||
output$x <-
|
||||
shiny::renderUI({
|
||||
columnSelectInput(inputId = "x",label = "X",data = gtsummary::trial)
|
||||
})
|
||||
|
||||
output$out <- renderText({
|
||||
# req(input$x)
|
||||
input$x
|
||||
})
|
||||
}
|
||||
|
||||
# shinyApp(ui,server)
|
||||
|
||||
testServer(server, {
|
||||
session$setInputs(x = "trt")
|
||||
expect_equal(output$out, "trt")
|
||||
|
||||
session$setInputs(x = "stage")
|
||||
expect_equal(output$out, "stage")
|
||||
})
|
||||
|
||||
})
|
||||
|
||||
test_that("Create columnSelectInput", {
|
||||
library(shiny)
|
||||
ui <- shiny::fluidPage(
|
||||
shiny::uiOutput("x"),
|
||||
shiny::uiOutput("out")
|
||||
)
|
||||
server <- function(input, output, session) {
|
||||
library(FreesearchR)
|
||||
output$x <-
|
||||
shiny::renderUI({
|
||||
vectorSelectInput(inputId = "x",choices = setNames(names(mtcars),seq_len(ncol(mtcars))),label = "X")
|
||||
})
|
||||
|
||||
output$out <- renderText({
|
||||
# req(input$x)
|
||||
input$x
|
||||
})
|
||||
}
|
||||
|
||||
# shinyApp(ui,server)
|
||||
|
||||
testServer(server, {
|
||||
session$setInputs(x = "cyl")
|
||||
expect_equal(output$out, "cyl")
|
||||
|
||||
session$setInputs(x = "mpg")
|
||||
expect_equal(output$out, "mpg")
|
||||
})
|
||||
expect_snapshot(columnSelectInput("x",label = "X",data = mtcars))
|
||||
})
|
||||
|
|
|
|||
|
|
@ -1,47 +0,0 @@
|
|||
test_that("datetime cutting works", {
|
||||
## HMS
|
||||
data <- readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "08:20:20", "21:20:20", "03:02:20"))
|
||||
|
||||
breaks <- list(2, "min", "hour", hms::as_hms(c("01:00:00", "03:01:20", "9:20:20")))
|
||||
|
||||
lapply(breaks, \(.x){
|
||||
cut_var(x = data, breaks = .x)
|
||||
}) |> expect_snapshot()
|
||||
|
||||
|
||||
data <- readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "03:02:20", NA))
|
||||
|
||||
lapply(breaks, \(.x){
|
||||
cut_var(x = data, breaks = .x)
|
||||
}) |> expect_snapshot()
|
||||
|
||||
expect_snapshot(
|
||||
readr::parse_time(c("01:00:20", "03:00:20", "01:20:20", "03:02:20", NA)) |> cut_var(breaks = lubridate::as_datetime(c(hms::as_hms(levels(cut_var(data, 2))), hms::as_hms(max(data, na.rm = TRUE) + 1))), right = FALSE)
|
||||
)
|
||||
|
||||
## DATETIME
|
||||
|
||||
data <- readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20"))
|
||||
|
||||
breaks <- list(list(breaks = 2), list(breaks = "weekday"), list(breaks = "month_only"), list(breaks = NULL, format = "%A-%H"))
|
||||
|
||||
lapply(breaks, \(.x){
|
||||
do.call(cut_var, modifyList(.x, list(x = data)))
|
||||
}) |> expect_snapshot()
|
||||
})
|
||||
|
||||
## is_any_class
|
||||
test_that("is_any_class works", {
|
||||
expect_snapshot(
|
||||
vapply(REDCapCAST::redcapcast_data, \(.x){
|
||||
is_any_class(.x, c("hms", "Date", "POSIXct", "POSIXt"))
|
||||
}, logical(1))
|
||||
)
|
||||
|
||||
expect_snapshot(
|
||||
vapply(REDCapCAST::redcapcast_data, is_datetime, logical(1))
|
||||
|
||||
)
|
||||
|
||||
})
|
||||
|
||||
|
|
@ -1,85 +0,0 @@
|
|||
## all_but
|
||||
test_that("all_but works", {
|
||||
expect_snapshot(all_but(1:10, c(2, 3), 11, 5))
|
||||
})
|
||||
|
||||
## subset_types
|
||||
test_that("subset_types works", {
|
||||
expect_snapshot(
|
||||
default_parsing(mtcars) |> subset_types("continuous")
|
||||
)
|
||||
expect_snapshot(
|
||||
default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal", "categorical"))
|
||||
)
|
||||
expect_snapshot(
|
||||
default_parsing(mtcars) |> subset_types("test")
|
||||
)
|
||||
})
|
||||
|
||||
## supported_plots
|
||||
test_that("supported_plots works", {
|
||||
expect_true(is.list(supported_plots()))
|
||||
})
|
||||
|
||||
## possible_plots
|
||||
test_that("possible_plots works", {
|
||||
expect_snapshot(possible_plots(mtcars$mpg))
|
||||
|
||||
expect_snapshot(default_parsing(mtcars)["cyl"] |>
|
||||
possible_plots())
|
||||
})
|
||||
|
||||
## get_plot_options
|
||||
test_that("get_plot_options works", {
|
||||
expect_snapshot(default_parsing(mtcars)["mpg"] |>
|
||||
possible_plots() |>
|
||||
(\(.x){
|
||||
.x[[1]]
|
||||
})() |>
|
||||
get_plot_options())
|
||||
})
|
||||
|
||||
## create_plot and friends
|
||||
test_that("create_plot works", {
|
||||
## Violin
|
||||
p_list <- create_plot(mtcars, type = "plot_violin", pri = "mpg", sec = "cyl", ter = "am")
|
||||
p <- p_list[[1]] + ggplot2::labs(title = "Test plot")
|
||||
|
||||
expect_equal(length(p_list), 2)
|
||||
expect_true(ggplot2::is.ggplot(p))
|
||||
|
||||
# Includes helper functions
|
||||
# wrap_plot_list
|
||||
# align_axes
|
||||
# clean_common_axis
|
||||
|
||||
## Scatter
|
||||
p_list <- list(
|
||||
create_plot(mtcars, type = "plot_scatter", pri = "mpg", sec = "cyl"),
|
||||
create_plot(mtcars, type = "plot_scatter", pri = "mpg", sec = "cyl", ter = "am")
|
||||
)
|
||||
|
||||
lapply(p_list, \(.x){
|
||||
expect_true(ggplot2::is.ggplot(.x))
|
||||
})
|
||||
|
||||
purrr::map2(p_list, list(11, 11), \(.x, .y){
|
||||
expect_equal(length(.x), .y)
|
||||
})
|
||||
})
|
||||
|
||||
## get_label
|
||||
test_that("get_label works", {
|
||||
expect_snapshot(mtcars |> get_label(var = "mpg"))
|
||||
expect_snapshot(mtcars |> get_label())
|
||||
expect_snapshot(mtcars$mpg |> get_label())
|
||||
expect_snapshot(gtsummary::trial |> get_label(var = "trt"))
|
||||
expect_snapshot(1:10 |> get_label())
|
||||
})
|
||||
|
||||
## line_break
|
||||
test_that("line_break works", {
|
||||
expect_snapshot("Lorem ipsum... you know the routine" |> line_break())
|
||||
expect_snapshot(paste(rep(letters, 5), collapse = "") |> line_break(force = TRUE, lineLength = 5))
|
||||
expect_snapshot(paste(rep(letters, 5), collapse = "") |> line_break(force = FALSE))
|
||||
})
|
||||
Loading…
Add table
Reference in a new issue