mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2026-06-19 04:27:30 +02:00
regression improvements
This commit is contained in:
parent
703daaec4b
commit
2dbc78310e
10 changed files with 2619 additions and 454 deletions
|
|
@ -31,9 +31,20 @@
|
|||
#' fun = "stats::glm",
|
||||
#' args.list = list(family = binomial(link = "logit"))
|
||||
#' )
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' regression_model(
|
||||
#' outcome.str = "mpg",
|
||||
#' auto.mode = FALSE,
|
||||
#' fun = "stats::lm",
|
||||
#' formula.str = "{outcome.str}~{paste(vars,collapse='+')}",
|
||||
#' args.list = NULL,
|
||||
#' vars = c("mpg", "cyl")
|
||||
#' ) |>
|
||||
#' summary()
|
||||
regression_model <- function(data,
|
||||
outcome.str,
|
||||
auto.mode = TRUE,
|
||||
auto.mode = FALSE,
|
||||
formula.str = NULL,
|
||||
args.list = NULL,
|
||||
fun = NULL,
|
||||
|
|
@ -45,20 +56,22 @@ regression_model <- function(data,
|
|||
}
|
||||
}
|
||||
|
||||
if (is.null(vars)) {
|
||||
vars <- names(data)[!names(data) %in% outcome.str]
|
||||
} else {
|
||||
if (outcome.str %in% vars) {
|
||||
vars <- vars[!vars %in% outcome.str]
|
||||
}
|
||||
data <- data |> dplyr::select(dplyr::all_of(c(vars, outcome.str)))
|
||||
}
|
||||
|
||||
if (!is.null(formula.str)) {
|
||||
formula.str <- glue::glue(formula.str)
|
||||
formula.glue <- glue::glue(formula.str)
|
||||
} else {
|
||||
assertthat::assert_that(outcome.str %in% names(data),
|
||||
msg = "Outcome variable is not present in the provided dataset"
|
||||
)
|
||||
formula.str <- glue::glue("{outcome.str}~.")
|
||||
|
||||
if (!is.null(vars)) {
|
||||
if (outcome.str %in% vars) {
|
||||
vars <- vars[vars %in% outcome.str]
|
||||
}
|
||||
data <- data |> dplyr::select(dplyr::all_of(c(vars, outcome.str)))
|
||||
}
|
||||
formula.glue <- glue::glue("{outcome.str}~{paste(vars,collapse='+')}")
|
||||
}
|
||||
|
||||
# Formatting character variables as factor
|
||||
|
|
@ -104,7 +117,7 @@ regression_model <- function(data,
|
|||
getfun(fun),
|
||||
c(
|
||||
list(data = data),
|
||||
list(formula = as.formula(formula.str)),
|
||||
list(formula = as.formula(formula.glue)),
|
||||
args.list
|
||||
)
|
||||
)
|
||||
|
|
@ -202,3 +215,384 @@ regression_model_uv <- function(data,
|
|||
return(out)
|
||||
}
|
||||
|
||||
|
||||
### HELPERS
|
||||
|
||||
#' Outcome data type assessment
|
||||
#'
|
||||
#' @param data data
|
||||
#'
|
||||
#' @returns outcome type
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' lapply(outcome_type)
|
||||
outcome_type <- function(data) {
|
||||
cl_d <- class(data)
|
||||
if (any(c("numeric", "integer") %in% cl_d)) {
|
||||
out <- "continuous"
|
||||
} else if (identical("factor", cl_d)) {
|
||||
if (length(levels(data)) == 2) {
|
||||
out <- "dichotomous"
|
||||
} else if (length(levels(data)) > 2) {
|
||||
out <- "ordinal"
|
||||
}
|
||||
} else {
|
||||
out <- "unknown"
|
||||
}
|
||||
|
||||
out
|
||||
}
|
||||
|
||||
|
||||
#' Implemented functions
|
||||
#'
|
||||
#' @description
|
||||
#' Library of supported functions. The list name and "descr" element should be
|
||||
#' unique for each element on list.
|
||||
#'
|
||||
#'
|
||||
#' @returns list
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' supported_functions()
|
||||
supported_functions <- function() {
|
||||
list(
|
||||
lm = list(
|
||||
descr = "Linear regression model",
|
||||
design = "cross-sectional",
|
||||
out.type = "continuous",
|
||||
fun = "stats::lm",
|
||||
args.list = NULL,
|
||||
formula.str = "{outcome.str}~{paste(vars,collapse='+')}"
|
||||
),
|
||||
glm = list(
|
||||
descr = "Logistic regression model",
|
||||
design = "cross-sectional",
|
||||
out.type = "dichotomous",
|
||||
fun = "stats::glm",
|
||||
args.list = list(family = stats::binomial(link = "logit")),
|
||||
formula.str = "{outcome.str}~{paste(vars,collapse='+')}"
|
||||
),
|
||||
polr = list(
|
||||
descr = "Ordinal logistic regression model",
|
||||
design = "cross-sectional",
|
||||
out.type = "ordinal",
|
||||
fun = "MASS::polr",
|
||||
args.list = list(
|
||||
Hess = TRUE,
|
||||
method = "logistic"
|
||||
),
|
||||
formula.str = "{outcome.str}~{paste(vars,collapse='+')}"
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
#' Get possible regression models
|
||||
#'
|
||||
#' @param data data
|
||||
#'
|
||||
#' @returns
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' dplyr::pull("cyl") |>
|
||||
#' possible_functions(design = "cross-sectional")
|
||||
#'
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' dplyr::select("cyl") |>
|
||||
#' possible_functions(design = "cross-sectional")
|
||||
possible_functions <- function(data, design = c("cross-sectional")) {
|
||||
# browser()
|
||||
if (is.data.frame(data)) {
|
||||
data <- data[[1]]
|
||||
}
|
||||
|
||||
design <- match.arg(design)
|
||||
type <- outcome_type(data)
|
||||
|
||||
design_ls <- supported_functions() |>
|
||||
lapply(\(.x){
|
||||
if (design %in% .x$design) {
|
||||
.x
|
||||
}
|
||||
})
|
||||
|
||||
if (type == "unknown") {
|
||||
out <- type
|
||||
} else {
|
||||
out <- design_ls |>
|
||||
lapply(\(.x){
|
||||
if (type %in% .x$out.type) {
|
||||
.x$descr
|
||||
}
|
||||
}) |>
|
||||
unlist()
|
||||
}
|
||||
unname(out)
|
||||
}
|
||||
|
||||
|
||||
#' Get the function options based on the selected function description
|
||||
#'
|
||||
#' @param data vector
|
||||
#'
|
||||
#' @returns list
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' dplyr::pull(mpg) |>
|
||||
#' possible_functions(design = "cross-sectional") |>
|
||||
#' (\(.x){
|
||||
#' .x[[1]]
|
||||
#' })() |>
|
||||
#' get_fun_options()
|
||||
get_fun_options <- function(data) {
|
||||
descrs <- supported_functions() |>
|
||||
lapply(\(.x){
|
||||
.x$descr
|
||||
}) |>
|
||||
unlist()
|
||||
supported_functions() |>
|
||||
(\(.x){
|
||||
.x[match(data, descrs)]
|
||||
})()
|
||||
}
|
||||
|
||||
|
||||
#' Wrapper to create regression model based on supported models
|
||||
#'
|
||||
#' @description
|
||||
#' Output is a concatenated list of model information and model
|
||||
#'
|
||||
#'
|
||||
#' @param data data
|
||||
#' @param outcome.str name of outcome variable
|
||||
#' @param fun.descr Description of chosen function matching description in
|
||||
#' "supported_functions()"
|
||||
#' @param fun name of custom function. Default is NULL.
|
||||
#' @param formula.str custom formula glue string. Default is NULL.
|
||||
#' @param args.list custom character string to be converted using
|
||||
#' argsstring2list() or list of arguments. Default is NULL.
|
||||
#' @param ... ignored
|
||||
#'
|
||||
#' @returns
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' gtsummary::trial |>
|
||||
#' regression_model(
|
||||
#' outcome.str = "age",
|
||||
#' fun = "stats::lm",
|
||||
#' formula.str = "{outcome.str}~.",
|
||||
#' args.list = NULL
|
||||
#' )
|
||||
#' ls <- regression_model_list(data = default_parsing(mtcars), outcome.str = "cyl", fun.descr = "Ordinal logistic regression model")
|
||||
#' summary(ls$model)
|
||||
regression_model_list <- function(data,
|
||||
outcome.str,
|
||||
fun.descr,
|
||||
fun = NULL,
|
||||
formula.str = NULL,
|
||||
args.list = NULL,
|
||||
vars = NULL,
|
||||
...) {
|
||||
options <- get_fun_options(fun.descr) |>
|
||||
(\(.x){
|
||||
.x[[1]]
|
||||
})()
|
||||
|
||||
## Custom, specific fun, args and formula options
|
||||
|
||||
if (is.null(formula.str)) {
|
||||
formula.str.c <- options$formula.str
|
||||
} else {
|
||||
formula.str.c <- formula.str
|
||||
}
|
||||
|
||||
if (is.null(fun)) {
|
||||
fun.c <- options$fun
|
||||
} else {
|
||||
fun.c <- fun
|
||||
}
|
||||
|
||||
if (is.null(args.list)) {
|
||||
args.list.c <- options$args.list
|
||||
} else {
|
||||
args.list.c <- args.list
|
||||
}
|
||||
|
||||
if (is.character(args.list.c)) args.list.c <- argsstring2list(args.list.c)
|
||||
|
||||
## Handling vars to print code
|
||||
|
||||
if (is.null(vars)) {
|
||||
vars <- names(data)[!names(data) %in% outcome.str]
|
||||
} else {
|
||||
if (outcome.str %in% vars) {
|
||||
vars <- vars[!vars %in% outcome.str]
|
||||
}
|
||||
}
|
||||
|
||||
model <- do.call(
|
||||
regression_model,
|
||||
c(
|
||||
list(data = data),
|
||||
list(outcome.str = outcome.str),
|
||||
list(fun = fun.c),
|
||||
list(formula.str = formula.str.c),
|
||||
args.list.c
|
||||
)
|
||||
)
|
||||
|
||||
code <- glue::glue(
|
||||
"{fun.c}({paste(Filter(length,list(glue::glue(formula.str.c),'data = data',list2str(args.list.c))),collapse=', ')})"
|
||||
)
|
||||
|
||||
list(
|
||||
options = options,
|
||||
model = model,
|
||||
code = code
|
||||
)
|
||||
}
|
||||
|
||||
list2str <- function(data) {
|
||||
out <- purrr::imap(data, \(.x, .i){
|
||||
if (is.logical(.x)) {
|
||||
arg <- .x
|
||||
} else {
|
||||
arg <- glue::glue("'{.x}'")
|
||||
}
|
||||
glue::glue("{.i} = {arg}")
|
||||
}) |>
|
||||
unlist() |>
|
||||
paste(collapse = (", "))
|
||||
|
||||
if (out==""){
|
||||
return(NULL)
|
||||
} else {
|
||||
out
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
#' Title
|
||||
#'
|
||||
#' @param data
|
||||
#' @param outcome.str
|
||||
#' @param fun.descr
|
||||
#' @param fun
|
||||
#' @param formula.str
|
||||
#' @param args.list
|
||||
#' @param vars
|
||||
#' @param ...
|
||||
#'
|
||||
#' @returns
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' gtsummary::trial |> regression_model_uv(
|
||||
#' outcome.str = "trt",
|
||||
#' fun = "stats::glm",
|
||||
#' args.list = list(family = stats::binomial(link = "logit"))
|
||||
#' )
|
||||
#' ms <- regression_model_uv_list(data = default_parsing(mtcars), outcome.str = "mpg", fun.descr = "Linear regression model")
|
||||
regression_model_uv_list <- function(data,
|
||||
outcome.str,
|
||||
fun.descr,
|
||||
fun = NULL,
|
||||
formula.str = NULL,
|
||||
args.list = NULL,
|
||||
vars = NULL,
|
||||
...) {
|
||||
|
||||
options <- get_fun_options(fun.descr) |>
|
||||
(\(.x){
|
||||
.x[[1]]
|
||||
})()
|
||||
|
||||
## Custom, specific fun, args and formula options
|
||||
|
||||
if (is.null(formula.str)) {
|
||||
formula.str.c <- options$formula.str
|
||||
} else {
|
||||
formula.str.c <- formula.str
|
||||
}
|
||||
|
||||
if (is.null(fun)) {
|
||||
fun.c <- options$fun
|
||||
} else {
|
||||
fun.c <- fun
|
||||
}
|
||||
|
||||
if (is.null(args.list)) {
|
||||
args.list.c <- options$args.list
|
||||
} else {
|
||||
args.list.c <- args.list
|
||||
}
|
||||
|
||||
if (is.character(args.list.c)) args.list.c <- argsstring2list(args.list.c)
|
||||
|
||||
## Handling vars to print code
|
||||
|
||||
if (is.null(vars)) {
|
||||
vars <- names(data)[!names(data) %in% outcome.str]
|
||||
} else {
|
||||
if (outcome.str %in% vars) {
|
||||
vars <- vars[!vars %in% outcome.str]
|
||||
}
|
||||
}
|
||||
|
||||
# assertthat::assert_that("character" %in% class(fun),
|
||||
# msg = "Please provide the function as a character vector."
|
||||
# )
|
||||
|
||||
# model <- do.call(
|
||||
# regression_model,
|
||||
# c(
|
||||
# list(data = data),
|
||||
# list(outcome.str = outcome.str),
|
||||
# list(fun = fun.c),
|
||||
# list(formula.str = formula.str.c),
|
||||
# args.list.c
|
||||
# )
|
||||
# )
|
||||
|
||||
model <- vars |>
|
||||
lapply(\(.var){
|
||||
do.call(
|
||||
regression_model,
|
||||
c(
|
||||
list(data = data[c(outcome.str, .var)]),
|
||||
list(outcome.str = outcome.str),
|
||||
list(fun = fun.c),
|
||||
list(formula.str = formula.str.c),
|
||||
args.list.c
|
||||
)
|
||||
)
|
||||
})
|
||||
|
||||
|
||||
vars <- "."
|
||||
|
||||
code_raw <- glue::glue(
|
||||
"{fun.c}({paste(Filter(length,list(glue::glue(formula.str.c),'data = .d',list2str(args.list.c))),collapse=', ')})"
|
||||
)
|
||||
|
||||
code <- glue::glue("lapply(data,function(.d){code_raw})")
|
||||
|
||||
list(
|
||||
options = options,
|
||||
model = model,
|
||||
code = code
|
||||
)
|
||||
}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue