Skip to content

Formula helpers fix #355

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
karissawhiting wants to merge 2 commits into
base: main
Choose a base branch
from
Open

Formula helpers fix #355

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
0666647
fix formual issue
karissawhiting Oct 29, 2025
e8115e3
temp fix for deprecated functions
karissawhiting Oct 29, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
4 changes: 2 additions & 2 deletions NAMESPACE
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,7 +1,9 @@
# Generated by roxygen2: do not edit by hand

export("%>%")
export(.formula_list_to_named_list)
export(.mutations_gene_binary)
export(.select_to_varnames)
export(.sum_alts_in_pathway)
export(add_pathways)
export(annotate_any_panel)
Expand Down Expand Up @@ -41,8 +43,6 @@ import(dplyr)
import(ggplot2)
import(stringr)
import(tidyr)
importFrom(broom.helpers,.formula_list_to_named_list)
importFrom(broom.helpers,.select_to_varnames)
importFrom(dplyr,"%>%")
importFrom(dplyr,arrange)
importFrom(dplyr,bind_cols)
Expand Down
1 change: 0 additions & 1 deletion R/gnomeR-package.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,6 @@
#' @importFrom dplyr mutate select n group_by ungroup filter pull case_when
#' if_else full_join left_join distinct bind_rows count coalesce arrange rename
#' rename_at bind_cols mutate_all mutate_at slice desc
#' @importFrom broom.helpers .formula_list_to_named_list .select_to_varnames
#' @importFrom utils tail
#' @keywords internal
"_PACKAGE"
Expand Down
199 changes: 199 additions & 0 deletions R/utils-exported-helpers.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -147,3 +147,202 @@ extract_patient_id <- function(sample_id) {
return(patient_id)
}


#' Convert formula selector to a named list
#' Functions takes a list of formulas, a named list, or a combination of named
#' elements with formula elements and returns a named list.
#' For example, `list(age = 1, starts_with("stage") ~ 2)`.
#'
#' @section Shortcuts:
#' A shortcut for specifying an option be applied to all columns/variables
#' is omitting the LHS of the formula.
#' For example, `list(~ 1)` is equivalent to passing `list(everything() ~ 1)`.
#'
#' Additionally, a single formula may be passed instead of placing a single
#' formula in a list; e.g. `everything() ~ 1` is equivalent to
#' passing `list(everything() ~ 1)`
#'
#' @param x list of selecting formulas
#' @param type_check A predicate function that checks the elements passed on
#' the RHS of the formulas in `x=` (or the element in a named list)
#' satisfy the function.
#' @param type_check_msg When the `type_check=` fails, the string provided
#' here will be printed as the error message. When `NULL`, a generic
#' error message will be printed.
#' @param null_allowed Are `NULL` values accepted for the right hand side of
#' formulas?
#' @inheritParams .select_to_varnames
#' @keywords internal
#' @export
.formula_list_to_named_list <- function(x, data = NULL, var_info = NULL,
arg_name = NULL, select_single = FALSE,
type_check = NULL, type_check_msg = NULL,
null_allowed = TRUE) {

# if NULL provided, return NULL ----------------------------------------------
if (is.null(x)) {
return(NULL)
}

# converting to list if single element passed --------------------------------
if (inherits(x, "formula")) {
x <- list(x)
}

# checking the input is valid ------------------------------------------------
.check_valid_input(x = x, arg_name = arg_name, type_check = type_check)

# convert to a named list ----------------------------------------------------
len_x <- length(x)
named_list <- vector(mode = "list", length = len_x)
for (i in seq_len(len_x)) {
if (rlang::is_named(x[i])) {
named_list[i] <- list(x[i])
} else if (rlang::is_formula(x[[i]])) {
named_list[i] <-
.single_formula_to_list(x[[i]],
data = data,
var_info = var_info,
arg_name = arg_name,
select_single = select_single,
type_check = type_check,
type_check_msg = type_check_msg,
null_allowed = null_allowed
) |>
list()
} else {
.formula_select_error(arg_name = arg_name)
}

.rhs_checks(
x = named_list[i][[1]], arg_name = arg_name, type_check = type_check,
type_check_msg = type_check_msg, null_allowed = null_allowed
)
}
named_list <- purrr::flatten(named_list)

# removing duplicates (using the last one listed if variable occurs more than once)
rd <- function(x) {
x <- rev(x)
x <- !duplicated(x)
rev(x)
}
tokeep <- names(named_list) |> rd()
result <- named_list[tokeep]

if (isTRUE(select_single) && length(result) > 1) {
.select_single_error_msg(names(result), arg_name = arg_name)
}
result
}


#' Variable selector
#'
#' Function takes `select()`-like inputs and converts the selector to
#' a character vector of variable names. Functions accepts tidyselect syntax,
#' and additional selector functions defined within the package
#'
#' @param select A single object selecting variables, e.g. `c(age, stage)`,
#' `starts_with("age")`
#' @param data A data frame to select columns from. Default is NULL
#' @param var_info A data frame of variable names and attributes. May also pass
#' a character vector of variable names. Default is NULL
#' @param arg_name Optional string indicating the source argument name. This
#' helps in the error messaging. Default is NULL.
#' @param select_single Logical indicating whether the result must be a single
#' variable. Default is `FALSE`
#'
#' @return A character vector of variable names
#' @keywords internal
#' @export
.select_to_varnames <- function(select, data = NULL, var_info = NULL,
arg_name = NULL, select_single = FALSE) {

if (is.null(data) && is.null(var_info)) {
cli::cli_abort("At least one of {.arg data} or {.arg var_info} must be specified.")
}

select <- rlang::enquo(select)

# if NULL passed, return NULL
if (rlang::quo_is_null(select)) {
return(NULL)
}

# if var_info is provided, scope it
if (!is.null(var_info)) data <- scope_tidy(var_info, data)

# determine if selecting input begins with `var()`
select_input_starts_var <-
!rlang::quo_is_symbol(select) && # if not a symbol (ie name)
tryCatch(
identical(
eval(as.list(rlang::quo_get_expr(select)) |> purrr::pluck(1)),
dplyr::vars
),
error = function(e) FALSE
)

# performing selecting
res <-
tryCatch(
{
if (select_input_starts_var) {
# `vars()` was deprecated on June 6, 2022, gtsummary will stop
# exporting `vars()` at some point as well.
paste(
"Use of {.code vars()} is now {.strong deprecated} and support will soon be removed.",
"Please replace calls to {.code vars()} with {.code c()}."
) |>
cli::cli_alert_warning()

# `vars()` evaluates to a list of quosures; unquoting them in `select()`
names(dplyr::select(data, !!!rlang::eval_tidy(select)))
} else {
names(dplyr::select(data, !!select))
}
},
error = function(e) {
if (!is.null(arg_name)) {
error_msg <- stringr::str_glue(
"Error in `{arg_name}=` argument input. Select from ",
"{paste(sQuote(names(data)), collapse = ', ')}"
)
} else {
error_msg <- as.character(e)
} # nocov
cli::cli_abort(error_msg, call = NULL)
}
)

# assuring only a single column is selected
if (select_single == TRUE && length(res) > 1) {
.select_single_error_msg(res, arg_name = arg_name)
}

# if nothing is selected, return a NULL
if (length(res) == 0) {
return(NULL)
}

res
}


.select_single_error_msg <- function(selected, arg_name) {
if (!rlang::is_empty(arg_name)) {
stringr::str_glue(
"Error in `{arg_name}=` argument--select only a single column. ",
"The following columns were selected, ",
"{paste(sQuote(selected), collapse = ', ')}"
) |>
cli::cli_abort(call = NULL)
}
stringr::str_glue(
"Error in selector--select only a single column. ",
"The following columns were selected, ",
"{paste(sQuote(selected), collapse = ', ')}"
) |>
cli::cli_abort(call = NULL)
}
2 changes: 1 addition & 1 deletion man/dot-check_for_fus_in_mut.Rd
View file
Open in desktop

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

63 changes: 63 additions & 0 deletions man/dot-formula_list_to_named_list.Rd
View file
Open in desktop

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

38 changes: 38 additions & 0 deletions man/dot-select_to_varnames.Rd
View file
Open in desktop

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

1 change: 1 addition & 0 deletions man/gnomeR-package.Rd
View file
Open in desktop

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

Binary file modified tests/testthat/Rplots.pdf
View file
Open in desktop
Binary file not shown.