andreas/FreesearchR
1
0
Fork 0
mirror of https://github.com/agdamsbo/FreesearchR.git synced 2026-06-19 04:27:30 +02:00
Code Issues Projects Releases Packages Wiki Activity

modifications to ui and using DT for tables

Browse source
This commit is contained in:
Andreas Gammelgaard Damsbo 2024-11-28 21:02:23 +01:00
commit 15fe4ca188
No known key found for this signature in database
16 changed files with 567 additions and 128 deletions
Download patch file Download diff file Expand all files Collapse all files

85
R/regression_table.R
View file

@ -1,13 +1,16 @@
#' Create table of regression model
#'
#' @param data regression model
#' @param x regression model
#' @param args.list list of arguments passed to 'fun'.
#' @param fun function to use for table creation. Default is "gtsummary::tbl_regression".
#' @param ... passed to methods
#'
#' @return object of standard class for fun
#' @export
#' @name regression_table
#'
#' @examples
#' \dontrun{
#' gtsummary::trial |>
#' regression_model(
#' outcome.str = "stage",
@ -29,14 +32,82 @@
#' args.list = list(family = binomial(link = "logit"))
#' ) |>
#' regression_table()
regression_table <- function(data, args.list = NULL, fun = "gtsummary::tbl_regression") {
#' gtsummary::trial |>
#' regression_model_uv(
#' outcome.str = "trt",
#' fun = "stats::glm",
#' args.list = list(family = stats::binomial(link = "logit"))
#' ) |>
#' regression_table()
#' gtsummary::trial |>
#' regression_model_uv(
#' outcome.str = "stage",
#' args.list = list(family = stats::binomial(link = "logit"))
#' ) |>
#' regression_table()
#'
#' list(
#' "Univariable" = regression_model_uv,
#' "Multivariable" = regression_model
#' ) |>
#' lapply(\(.fun){
#' do.call(
#' .fun,
#' c(
#' list(data = gtsummary::trial),
#' list(outcome.str = "stage")
#' )
#' )
#' }) |>
#' purrr::map(regression_table) |>
#' tbl_merge()
#' }
regression_table <- function(x, ...) {
UseMethod("regression_table")
}
if (any(c(length(class(data))!=1, class(data)!="lm"))){
if (!"exponentiate" %in% names(args.list)){
args.list <- c(args.list,list(exponentiate=TRUE))
#' @rdname regression_table
#' @export
regression_table.list <- function(x, ...) {
x |>
purrr::map(\(.m){
regression_table(x = .m, ...) |>
gtsummary::add_n()
}) |>
gtsummary::tbl_stack()
}
#' @rdname regression_table
#' @export
regression_table.webresearch_model <- function(x, ..., args.list = NULL, fun = "gtsummary::tbl_regression") {
# Stripping custom class
class(x) <- class(x)[class(x) != "webresearch_model"]
if (any(c(length(class(x)) != 1, class(x) != "lm"))) {
if (!"exponentiate" %in% names(args.list)) {
args.list <- c(args.list, list(exponentiate = TRUE))
}
}
out <- do.call(getfun(fun), c(list(x = data), args.list))
out |> gtsummary::add_glance_source_note()
out <- do.call(getfun(fun), c(list(x = x), args.list))
out |>
gtsummary::add_glance_source_note() # |>
# gtsummary::bold_p()
}
#' A substitue to gtsummary::tbl_merge, that will use list names for the tab
#' spanner names.
#'
#' @param data gtsummary list object
#'
#' @return gt summary list object
#' @export
#'
tbl_merge <- function(data) {
if (is.null(names(data))) {
data |> gtsummary::tbl_merge()
} else {
data |> gtsummary::tbl_merge(tab_spanner = names(data))
}
}