andreas/FreesearchR
1
0
Fork 0
mirror of https://github.com/agdamsbo/FreesearchR.git synced 2025-09-12 18:09:39 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

adjusted to correctly handle args.list and non-existing outcome

Browse source
This commit is contained in:
Andreas Gammelgaard Damsbo 2025-01-30 14:31:38 +01:00
parent acc112bc73
commit 48d6b895aa
No known key found for this signature in database
1 changed files with 76 additions and 34 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

98
R/regression_model.R
View file

@ -25,13 +25,15 @@
#' formula.str = "{outcome.str}~.", #' formula.str = "{outcome.str}~.",
#' args.list = NULL #' args.list = NULL
#' ) #' )
#' gtsummary::trial |> regression_model( #' gtsummary::trial |>
#' default_parsing() |>
#' regression_model(
#' outcome.str = "trt", #' outcome.str = "trt",
#' auto.mode = FALSE, #' auto.mode = FALSE,
#' fun = "stats::glm", #' fun = "stats::glm",
#' args.list = list(family = binomial(link = "logit")) #' args.list = list(family = binomial(link = "logit"))
#' ) #' )
#' mtcars |> #' m <- mtcars |>
#' default_parsing() |> #' default_parsing() |>
#' regression_model( #' regression_model(
#' outcome.str = "mpg", #' outcome.str = "mpg",
@ -40,8 +42,8 @@
#' formula.str = "{outcome.str}~{paste(vars,collapse='+')}", #' formula.str = "{outcome.str}~{paste(vars,collapse='+')}",
#' args.list = NULL, #' args.list = NULL,
#' vars = c("mpg", "cyl") #' vars = c("mpg", "cyl")
#' ) |> #' )
#' summary() #' broom::tidy(m)
regression_model <- function(data, regression_model <- function(data,
outcome.str, outcome.str,
auto.mode = FALSE, auto.mode = FALSE,
@ -56,6 +58,12 @@ regression_model <- function(data,
} }
} }
## This will handle if outcome is not in data for nicer shiny behavior
if (!outcome.str %in% names(data)){
outcome.str <- names(data)[1]
print("outcome is not in data, first column is used")
}
if (is.null(vars)) { if (is.null(vars)) {
vars <- names(data)[!names(data) %in% outcome.str] vars <- names(data)[!names(data) %in% outcome.str]
} else { } else {
@ -113,11 +121,14 @@ regression_model <- function(data,
msg = "Please provide the function as a character vector." msg = "Please provide the function as a character vector."
) )
# browser()
out <- do.call( out <- do.call(
getfun(fun), getfun(fun),
c( c(
list(data = data), list(
list(formula = as.formula(formula.glue)), data = data,
formula = as.formula(formula.glue)
),
args.list args.list
) )
) )
@ -152,11 +163,12 @@ regression_model <- function(data,
#' fun = "stats::lm", #' fun = "stats::lm",
#' args.list = NULL #' args.list = NULL
#' ) #' )
#' gtsummary::trial |> regression_model_uv( #' m <- gtsummary::trial |> regression_model_uv(
#' outcome.str = "trt", #' outcome.str = "trt",
#' fun = "stats::glm", #' fun = "stats::glm",
#' args.list = list(family = stats::binomial(link = "logit")) #' args.list = list(family = stats::binomial(link = "logit"))
#' ) #' )
#' lapply(m,broom::tidy) |> dplyr::bind_rows()
#' } #' }
regression_model_uv <- function(data, regression_model_uv <- function(data,
outcome.str, outcome.str,
@ -164,6 +176,13 @@ regression_model_uv <- function(data,
fun = NULL, fun = NULL,
vars = NULL, vars = NULL,
...) { ...) {
## This will handle if outcome is not in data for nicer shiny behavior
if (!outcome.str %in% names(data)){
outcome.str <- names(data)[1]
print("outcome is not in data, first column is used")
}
if (!is.null(vars)) { if (!is.null(vars)) {
data <- data |> data <- data |>
dplyr::select(dplyr::all_of( dplyr::select(dplyr::all_of(
@ -205,9 +224,11 @@ regression_model_uv <- function(data,
do.call( do.call(
regression_model, regression_model,
c( c(
list(data = data[match(c(outcome.str, .var), names(data))]), list(
list(outcome.str = outcome.str), data = data[match(c(outcome.str, .var), names(data))],
list(args.list = args.list) outcome.str = outcome.str
),
args.list
) )
) )
}) })
@ -268,7 +289,8 @@ supported_functions <- function() {
fun = "stats::lm", fun = "stats::lm",
args.list = NULL, args.list = NULL,
formula.str = "{outcome.str}~{paste(vars,collapse='+')}", formula.str = "{outcome.str}~{paste(vars,collapse='+')}",
table.fun = "gtsummary::tbl_regression" table.fun = "gtsummary::tbl_regression",
table.args.list = list(exponentiate = FALSE)
), ),
glm = list( glm = list(
descr = "Logistic regression model", descr = "Logistic regression model",
@ -277,7 +299,8 @@ supported_functions <- function() {
fun = "stats::glm", fun = "stats::glm",
args.list = list(family = stats::binomial(link = "logit")), args.list = list(family = stats::binomial(link = "logit")),
formula.str = "{outcome.str}~{paste(vars,collapse='+')}", formula.str = "{outcome.str}~{paste(vars,collapse='+')}",
table.fun = "gtsummary::tbl_regression" table.fun = "gtsummary::tbl_regression",
table.args.list = list()
), ),
polr = list( polr = list(
descr = "Ordinal logistic regression model", descr = "Ordinal logistic regression model",
@ -289,7 +312,8 @@ supported_functions <- function() {
method = "logistic" method = "logistic"
), ),
formula.str = "{outcome.str}~{paste(vars,collapse='+')}", formula.str = "{outcome.str}~{paste(vars,collapse='+')}",
table.fun = "gtsummary::tbl_regression" table.fun = "gtsummary::tbl_regression",
table.args.list = list()
) )
) )
} }
@ -392,6 +416,7 @@ get_fun_options <- function(data) {
#' @export #' @export
#' #'
#' @examples #' @examples
#' \dontrun{
#' gtsummary::trial |> #' gtsummary::trial |>
#' regression_model( #' regression_model(
#' outcome.str = "age", #' outcome.str = "age",
@ -401,6 +426,21 @@ get_fun_options <- function(data) {
#' ) #' )
#' ls <- regression_model_list(data = default_parsing(mtcars), outcome.str = "cyl", fun.descr = "Ordinal logistic regression model") #' ls <- regression_model_list(data = default_parsing(mtcars), outcome.str = "cyl", fun.descr = "Ordinal logistic regression model")
#' summary(ls$model) #' summary(ls$model)
#'
#' ls <- regression_model_list(data = default_parsing(gtsummary::trial), outcome.str = "trt", fun.descr = "Logistic regression model")
#' tbl <- gtsummary::tbl_regression(ls$model, exponentiate = TRUE)
#' m <- gtsummary::trial |>
#' default_parsing() |>
#' regression_model(
#' outcome.str = "trt",
#' fun = "stats::glm",
#' formula.str = "{outcome.str}~.",
#' args.list = list(family = stats::binomial(link = "logit"))
#' )
#' tbl2 <- gtsummary::tbl_regression(m, exponentiate = TRUE)
#' broom::tidy(ls$model)
#' broom::tidy(m)
#' }
regression_model_list <- function(data, regression_model_list <- function(data,
outcome.str, outcome.str,
fun.descr, fun.descr,
@ -448,12 +488,12 @@ regression_model_list <- function(data,
model <- do.call( model <- do.call(
regression_model, regression_model,
c( list(
list(data = data), data = data,
list(outcome.str = outcome.str), outcome.str = outcome.str,
list(fun = fun.c), fun = fun.c,
list(formula.str = formula.str.c), formula.str = formula.str.c,
args.list.c args.list = args.list.c
) )
) )
@ -499,16 +539,19 @@ list2str <- function(data) {
#' @param vars #' @param vars
#' @param ... #' @param ...
#' #'
#' @returns #' @returns list
#' @export #' @export
#' #'
#' @examples #' @examples
#' \dontrun{
#' gtsummary::trial |> regression_model_uv( #' gtsummary::trial |> regression_model_uv(
#' outcome.str = "trt", #' outcome.str = "trt",
#' fun = "stats::glm", #' fun = "stats::glm",
#' args.list = list(family = stats::binomial(link = "logit")) #' args.list = list(family = stats::binomial(link = "logit"))
#' ) #' ) |> lapply(broom::tidy) |> dplyr::bind_rows()
#' ms <- regression_model_uv_list(data = default_parsing(mtcars), outcome.str = "mpg", fun.descr = "Linear regression model") #' ms <- regression_model_uv_list(data = default_parsing(mtcars), outcome.str = "mpg", fun.descr = "Linear regression model")
#' lapply(ms$model,broom::tidy) |> dplyr::bind_rows()
#' }
regression_model_uv_list <- function(data, regression_model_uv_list <- function(data,
outcome.str, outcome.str,
fun.descr, fun.descr,
@ -517,7 +560,6 @@ regression_model_uv_list <- function(data,
args.list = NULL, args.list = NULL,
vars = NULL, vars = NULL,
...) { ...) {
options <- get_fun_options(fun.descr) |> options <- get_fun_options(fun.descr) |>
(\(.x){ (\(.x){
.x[[1]] .x[[1]]
@ -574,12 +616,12 @@ regression_model_uv_list <- function(data,
lapply(\(.var){ lapply(\(.var){
do.call( do.call(
regression_model, regression_model,
c( list(
list(data = data[c(outcome.str, .var)]), data = data[c(outcome.str, .var)],
list(outcome.str = outcome.str), outcome.str = outcome.str,
list(fun = fun.c), fun = fun.c,
list(formula.str = formula.str.c), formula.str = formula.str.c,
args.list.c args.list = args.list.c
) )
) )
}) })